vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170 #ifdef __DECC
 171 #pragma message restore
 172 #pragma member_alignment restore
 173 #endif
 174
 175 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 176 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 177 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 178 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 179 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 180 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 181 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 182 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 183 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 184 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 185 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 186
 187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 191
 192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 194
 195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 196  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 197  * the Perl facility.
 198  */
 199 #define PERL_LNM_MAX_ITER 10
 200
 201   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 203 #define MAX_DCL_SYMBOL          (8192)
 204 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 205 #else
 206 #define MAX_DCL_SYMBOL          (1024)
 207 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 208 #endif
 209
 210 static char *__mystrtolower(char *str)
 211 {
 212   if (str) for (; *str; ++str) *str= tolower(*str);
 213   return str;
 214 }
 215
 216 static struct dsc$descriptor_s fildevdsc =
 217   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 218 static struct dsc$descriptor_s crtlenvdsc =
 219   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 222 static struct dsc$descriptor_s **env_tables = defenv;
 223 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 224
 225 /* True if we shouldn't treat barewords as logicals during directory */
 226 /* munching */
 227 static int no_translate_barewords;
 228
 229 #ifndef RTL_USES_UTC
 230 static int tz_updated = 1;
 231 #endif
 232
 233 /* DECC Features that may need to affect how Perl interprets
 234  * displays filename information
 235  */
 236 static int decc_disable_to_vms_logname_translation = 1;
 237 static int decc_disable_posix_root = 1;
 238 int decc_efs_case_preserve = 0;
 239 static int decc_efs_charset = 0;
 240 static int decc_filename_unix_no_version = 0;
 241 static int decc_filename_unix_only = 0;
 242 int decc_filename_unix_report = 0;
 243 int decc_posix_compliant_pathnames = 0;
 244 int decc_readdir_dropdotnotype = 0;
 245 static int vms_process_case_tolerant = 1;
 246
 247 /* bug workarounds if needed */
 248 int decc_bug_readdir_efs1 = 0;
 249 int decc_bug_devnull = 1;
 250 int decc_bug_fgetname = 0;
 251 int decc_dir_barename = 0;
 252
 253 /* Is this a UNIX file specification?
 254  *   No longer a simple check with EFS file specs
 255  *   For now, not a full check, but need to
 256  *   handle POSIX ^UP^ specifications
 257  *   Fixing to handle ^/ cases would require
 258  *   changes to many other conversion routines.
 259  */
 260
 261 static is_unix_filespec(const char *path)
 262 {
 263 int ret_val;
 264 const char * pch1;
 265
 266     ret_val = 0;
 267     if (strncmp(path,"\"^UP^",5) != 0) {
 268         pch1 = strchr(path, '/');
 269         if (pch1 != NULL)
 270             ret_val = 1;
 271         else {
 272
 273             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 274             if (decc_filename_unix_report || decc_filename_unix_only) {
 275             if (strcmp(path,".") == 0)
 276                 ret_val = 1;
 277             }
 278         }
 279     }
 280     return ret_val;
 281 }
 282
 283
 284 /* my_maxidx
 285  * Routine to retrieve the maximum equivalence index for an input
 286  * logical name.  Some calls to this routine have no knowledge if
 287  * the variable is a logical or not.  So on error we return a max
 288  * index of zero.
 289  */
 290 /*{{{int my_maxidx(const char *lnm) */
 291 static int
 292 my_maxidx(const char *lnm)
 293 {
 294     int status;
 295     int midx;
 296     int attr = LNM$M_CASE_BLIND;
 297     struct dsc$descriptor lnmdsc;
 298     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 299                                 {0, 0, 0, 0}};
 300
 301     lnmdsc.dsc$w_length = strlen(lnm);
 302     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 303     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 304     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 305
 306     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 307     if ((status & 1) == 0)
 308        midx = 0;
 309
 310     return (midx);
 311 }
 312 /*}}}*/
 313
 314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 315 int
 316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 317   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 318 {
 319     const char *cp1;
 320     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 321     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 322     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 323     int midx;
 324     unsigned char acmode;
 325     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 326                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 327     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 328                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 329                                  {0, 0, 0, 0}};
 330     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 331 #if defined(PERL_IMPLICIT_CONTEXT)
 332     pTHX = NULL;
 333     if (PL_curinterp) {
 334       aTHX = PERL_GET_INTERP;
 335     } else {
 336       aTHX = NULL;
 337     }
 338 #endif
 339
 340     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 341       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 342     }
 343     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 344       *cp2 = _toupper(*cp1);
 345       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 346         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 347         return 0;
 348       }
 349     }
 350     lnmdsc.dsc$w_length = cp1 - lnm;
 351     lnmdsc.dsc$a_pointer = uplnm;
 352     uplnm[lnmdsc.dsc$w_length] = '\0';
 353     secure = flags & PERL__TRNENV_SECURE;
 354     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 355     if (!tabvec || !*tabvec) tabvec = env_tables;
 356
 357     for (curtab = 0; tabvec[curtab]; curtab++) {
 358       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 359         if (!ivenv && !secure) {
 360           char *eq, *end;
 361           int i;
 362           if (!environ) {
 363             ivenv = 1;
 364             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 365             continue;
 366           }
 367           retsts = SS$_NOLOGNAM;
 368           for (i = 0; environ[i]; i++) {
 369             if ((eq = strchr(environ[i],'=')) &&
 370                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 371                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 372               eq++;
 373               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 374               if (!eqvlen) continue;
 375               retsts = SS$_NORMAL;
 376               break;
 377             }
 378           }
 379           if (retsts != SS$_NOLOGNAM) break;
 380         }
 381       }
 382       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 383                !str$case_blind_compare(&tmpdsc,&clisym)) {
 384         if (!ivsym && !secure) {
 385           unsigned short int deflen = LNM$C_NAMLENGTH;
 386           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 387           /* dynamic dsc to accomodate possible long value */
 388           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 389           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 390           if (retsts & 1) {
 391             if (eqvlen > MAX_DCL_SYMBOL) {
 392               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 393               eqvlen = MAX_DCL_SYMBOL;
 394               /* Special hack--we might be called before the interpreter's */
 395               /* fully initialized, in which case either thr or PL_curcop */
 396               /* might be bogus. We have to check, since ckWARN needs them */
 397               /* both to be valid if running threaded */
 398                 if (ckWARN(WARN_MISC)) {
 399                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 400                 }
 401             }
 402             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 403           }
 404           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 405           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 406           if (retsts == LIB$_NOSUCHSYM) continue;
 407           break;
 408         }
 409       }
 410       else if (!ivlnm) {
 411         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 412           midx = my_maxidx(lnm);
 413           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 414             lnmlst[1].bufadr = cp2;
 415             eqvlen = 0;
 416             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 417             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 418             if (retsts == SS$_NOLOGNAM) break;
 419             /* PPFs have a prefix */
 420             if (
 421 #if INTSIZE == 4
 422                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 423 #endif
 424                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 425                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 426                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 427                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 428                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 429               memmove(eqv,eqv+4,eqvlen-4);
 430               eqvlen -= 4;
 431             }
 432             cp2 += eqvlen;
 433             *cp2 = '\0';
 434           }
 435           if ((retsts == SS$_IVLOGNAM) ||
 436               (retsts == SS$_NOLOGNAM)) { continue; }
 437         }
 438         else {
 439           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 440           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 441           if (retsts == SS$_NOLOGNAM) continue;
 442           eqv[eqvlen] = '\0';
 443         }
 444         eqvlen = strlen(eqv);
 445         break;
 446       }
 447     }
 448     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 449     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 450              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 451              retsts == SS$_NOLOGNAM) {
 452       set_errno(EINVAL);  set_vaxc_errno(retsts);
 453     }
 454     else _ckvmssts(retsts);
 455     return 0;
 456 }  /* end of vmstrnenv */
 457 /*}}}*/
 458
 459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 460 /* Define as a function so we can access statics. */
 461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 462 {
 463   return vmstrnenv(lnm,eqv,idx,fildev,
 464 #ifdef SECURE_INTERNAL_GETENV
 465                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 466 #else
 467                    0
 468 #endif
 469                                                                               );
 470 }
 471 /*}}}*/
 472
 473 /* my_getenv
 474  * Note: Uses Perl temp to store result so char * can be returned to
 475  * caller; this pointer will be invalidated at next Perl statement
 476  * transition.
 477  * We define this as a function rather than a macro in terms of my_getenv_len()
 478  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 479  * allocate SVs).
 480  */
 481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 482 char *
 483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 484 {
 485     const char *cp1;
 486     static char *__my_getenv_eqv = NULL;
 487     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 488     unsigned long int idx = 0;
 489     int trnsuccess, success, secure, saverr, savvmserr;
 490     int midx, flags;
 491     SV *tmpsv;
 492
 493     midx = my_maxidx(lnm) + 1;
 494
 495     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 496       /* Set up a temporary buffer for the return value; Perl will
 497        * clean it up at the next statement transition */
 498       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 499       if (!tmpsv) return NULL;
 500       eqv = SvPVX(tmpsv);
 501     }
 502     else {
 503       /* Assume no interpreter ==> single thread */
 504       if (__my_getenv_eqv != NULL) {
 505         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 506       }
 507       else {
 508         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 509       }
 510       eqv = __my_getenv_eqv;
 511     }
 512
 513     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 514     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 515       int len;
 516       getcwd(eqv,LNM$C_NAMLENGTH);
 517
 518       len = strlen(eqv);
 519
 520       /* Get rid of "000000/ in rooted filespecs */
 521       if (len > 7) {
 522         char * zeros;
 523         zeros = strstr(eqv, "/000000/");
 524         if (zeros != NULL) {
 525           int mlen;
 526           mlen = len - (zeros - eqv) - 7;
 527           memmove(zeros, &zeros[7], mlen);
 528           len = len - 7;
 529           eqv[len] = '\0';
 530         }
 531       }
 532       return eqv;
 533     }
 534     else {
 535       /* Impose security constraints only if tainting */
 536       if (sys) {
 537         /* Impose security constraints only if tainting */
 538         secure = PL_curinterp ? PL_tainting : will_taint;
 539         saverr = errno;  savvmserr = vaxc$errno;
 540       }
 541       else {
 542         secure = 0;
 543       }
 544
 545       flags =
 546 #ifdef SECURE_INTERNAL_GETENV
 547               secure ? PERL__TRNENV_SECURE : 0
 548 #else
 549               0
 550 #endif
 551       ;
 552
 553       /* For the getenv interface we combine all the equivalence names
 554        * of a search list logical into one value to acquire a maximum
 555        * value length of 255*128 (assuming %ENV is using logicals).
 556        */
 557       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 558
 559       /* If the name contains a semicolon-delimited index, parse it
 560        * off and make sure we only retrieve the equivalence name for
 561        * that index.  */
 562       if ((cp2 = strchr(lnm,';')) != NULL) {
 563         strcpy(uplnm,lnm);
 564         uplnm[cp2-lnm] = '\0';
 565         idx = strtoul(cp2+1,NULL,0);
 566         lnm = uplnm;
 567         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 568       }
 569
 570       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 571
 572       /* Discard NOLOGNAM on internal calls since we're often looking
 573        * for an optional name, and this "error" often shows up as the
 574        * (bogus) exit status for a die() call later on.  */
 575       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 576       return success ? eqv : Nullch;
 577     }
 578
 579 }  /* end of my_getenv() */
 580 /*}}}*/
 581
 582
 583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 584 char *
 585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 586 {
 587     const char *cp1;
 588     char *buf, *cp2;
 589     unsigned long idx = 0;
 590     int midx, flags;
 591     static char *__my_getenv_len_eqv = NULL;
 592     int secure, saverr, savvmserr;
 593     SV *tmpsv;
 594
 595     midx = my_maxidx(lnm) + 1;
 596
 597     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 598       /* Set up a temporary buffer for the return value; Perl will
 599        * clean it up at the next statement transition */
 600       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 601       if (!tmpsv) return NULL;
 602       buf = SvPVX(tmpsv);
 603     }
 604     else {
 605       /* Assume no interpreter ==> single thread */
 606       if (__my_getenv_len_eqv != NULL) {
 607         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 608       }
 609       else {
 610         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 611       }
 612       buf = __my_getenv_len_eqv;
 613     }
 614
 615     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 616     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 617     char * zeros;
 618
 619       getcwd(buf,LNM$C_NAMLENGTH);
 620       *len = strlen(buf);
 621
 622       /* Get rid of "000000/ in rooted filespecs */
 623       if (*len > 7) {
 624       zeros = strstr(buf, "/000000/");
 625       if (zeros != NULL) {
 626         int mlen;
 627         mlen = *len - (zeros - buf) - 7;
 628         memmove(zeros, &zeros[7], mlen);
 629         *len = *len - 7;
 630         buf[*len] = '\0';
 631         }
 632       }
 633       return buf;
 634     }
 635     else {
 636       if (sys) {
 637         /* Impose security constraints only if tainting */
 638         secure = PL_curinterp ? PL_tainting : will_taint;
 639         saverr = errno;  savvmserr = vaxc$errno;
 640       }
 641       else {
 642         secure = 0;
 643       }
 644
 645       flags =
 646 #ifdef SECURE_INTERNAL_GETENV
 647               secure ? PERL__TRNENV_SECURE : 0
 648 #else
 649               0
 650 #endif
 651       ;
 652
 653       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 654
 655       if ((cp2 = strchr(lnm,';')) != NULL) {
 656         strcpy(buf,lnm);
 657         buf[cp2-lnm] = '\0';
 658         idx = strtoul(cp2+1,NULL,0);
 659         lnm = buf;
 660         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 661       }
 662
 663       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 664
 665       /* Get rid of "000000/ in rooted filespecs */
 666       if (*len > 7) {
 667       char * zeros;
 668         zeros = strstr(buf, "/000000/");
 669         if (zeros != NULL) {
 670           int mlen;
 671           mlen = *len - (zeros - buf) - 7;
 672           memmove(zeros, &zeros[7], mlen);
 673           *len = *len - 7;
 674           buf[*len] = '\0';
 675         }
 676       }
 677
 678       /* Discard NOLOGNAM on internal calls since we're often looking
 679        * for an optional name, and this "error" often shows up as the
 680        * (bogus) exit status for a die() call later on.  */
 681       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 682       return *len ? buf : Nullch;
 683     }
 684
 685 }  /* end of my_getenv_len() */
 686 /*}}}*/
 687
 688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 689
 690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 691
 692 /*{{{ void prime_env_iter() */
 693 void
 694 prime_env_iter(void)
 695 /* Fill the %ENV associative array with all logical names we can
 696  * find, in preparation for iterating over it.
 697  */
 698 {
 699   static int primed = 0;
 700   HV *seenhv = NULL, *envhv;
 701   SV *sv = NULL;
 702   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 703   unsigned short int chan;
 704 #ifndef CLI$M_TRUSTED
 705 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 706 #endif
 707   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 708   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 709   long int i;
 710   bool have_sym = FALSE, have_lnm = FALSE;
 711   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 712   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 713   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 714   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 715   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 716 #if defined(PERL_IMPLICIT_CONTEXT)
 717   pTHX;
 718 #endif
 719 #if defined(USE_ITHREADS)
 720   static perl_mutex primenv_mutex;
 721   MUTEX_INIT(&primenv_mutex);
 722 #endif
 723
 724 #if defined(PERL_IMPLICIT_CONTEXT)
 725     /* We jump through these hoops because we can be called at */
 726     /* platform-specific initialization time, which is before anything is */
 727     /* set up--we can't even do a plain dTHX since that relies on the */
 728     /* interpreter structure to be initialized */
 729     if (PL_curinterp) {
 730       aTHX = PERL_GET_INTERP;
 731     } else {
 732       aTHX = NULL;
 733     }
 734 #endif
 735
 736   if (primed || !PL_envgv) return;
 737   MUTEX_LOCK(&primenv_mutex);
 738   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 739   envhv = GvHVn(PL_envgv);
 740   /* Perform a dummy fetch as an lval to insure that the hash table is
 741    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 742   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 743
 744   for (i = 0; env_tables[i]; i++) {
 745      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 746          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 747      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 748   }
 749   if (have_sym || have_lnm) {
 750     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 751     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 752     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 753     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 754   }
 755
 756   for (i--; i >= 0; i--) {
 757     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 758       char *start;
 759       int j;
 760       for (j = 0; environ[j]; j++) {
 761         if (!(start = strchr(environ[j],'='))) {
 762           if (ckWARN(WARN_INTERNAL))
 763             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 764         }
 765         else {
 766           start++;
 767           sv = newSVpv(start,0);
 768           SvTAINTED_on(sv);
 769           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 770         }
 771       }
 772       continue;
 773     }
 774     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 775              !str$case_blind_compare(&tmpdsc,&clisym)) {
 776       strcpy(cmd,"Show Symbol/Global *");
 777       cmddsc.dsc$w_length = 20;
 778       if (env_tables[i]->dsc$w_length == 12 &&
 779           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 780           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 781       flags = defflags | CLI$M_NOLOGNAM;
 782     }
 783     else {
 784       strcpy(cmd,"Show Logical *");
 785       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 786         strcat(cmd," /Table=");
 787         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 788         cmddsc.dsc$w_length = strlen(cmd);
 789       }
 790       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 791       flags = defflags | CLI$M_NOCLISYM;
 792     }
 793
 794     /* Create a new subprocess to execute each command, to exclude the
 795      * remote possibility that someone could subvert a mbx or file used
 796      * to write multiple commands to a single subprocess.
 797      */
 798     do {
 799       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 800                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 801       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 802       defflags &= ~CLI$M_TRUSTED;
 803     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 804     _ckvmssts(retsts);
 805     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 806     if (seenhv) SvREFCNT_dec(seenhv);
 807     seenhv = newHV();
 808     while (1) {
 809       char *cp1, *cp2, *key;
 810       unsigned long int sts, iosb[2], retlen, keylen;
 811       register U32 hash;
 812
 813       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 814       if (sts & 1) sts = iosb[0] & 0xffff;
 815       if (sts == SS$_ENDOFFILE) {
 816         int wakect = 0;
 817         while (substs == 0) { sys$hiber(); wakect++;}
 818         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 819         _ckvmssts(substs);
 820         break;
 821       }
 822       _ckvmssts(sts);
 823       retlen = iosb[0] >> 16;
 824       if (!retlen) continue;  /* blank line */
 825       buf[retlen] = '\0';
 826       if (iosb[1] != subpid) {
 827         if (iosb[1]) {
 828           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 829         }
 830         continue;
 831       }
 832       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 833         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 834
 835       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 836       if (*cp1 == '(' || /* Logical name table name */
 837           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 838       if (*cp1 == '"') cp1++;
 839       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 840       key = cp1;  keylen = cp2 - cp1;
 841       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 842       while (*cp2 && *cp2 != '=') cp2++;
 843       while (*cp2 && *cp2 == '=') cp2++;
 844       while (*cp2 && *cp2 == ' ') cp2++;
 845       if (*cp2 == '"') {  /* String translation; may embed "" */
 846         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 847         cp2++;  cp1--; /* Skip "" surrounding translation */
 848       }
 849       else {  /* Numeric translation */
 850         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 851         cp1--;  /* stop on last non-space char */
 852       }
 853       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 854         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 855         continue;
 856       }
 857       PERL_HASH(hash,key,keylen);
 858
 859       if (cp1 == cp2 && *cp2 == '.') {
 860         /* A single dot usually means an unprintable character, such as a null
 861          * to indicate a zero-length value.  Get the actual value to make sure.
 862          */
 863         char lnm[LNM$C_NAMLENGTH+1];
 864         char eqv[MAX_DCL_SYMBOL+1];
 865         strncpy(lnm, key, keylen);
 866         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 867         sv = newSVpvn(eqv, strlen(eqv));
 868       }
 869       else {
 870         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 871       }
 872
 873       SvTAINTED_on(sv);
 874       hv_store(envhv,key,keylen,sv,hash);
 875       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 876     }
 877     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 878       /* get the PPFs for this process, not the subprocess */
 879       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 880       char eqv[LNM$C_NAMLENGTH+1];
 881       int trnlen, i;
 882       for (i = 0; ppfs[i]; i++) {
 883         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 884         sv = newSVpv(eqv,trnlen);
 885         SvTAINTED_on(sv);
 886         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 887       }
 888     }
 889   }
 890   primed = 1;
 891   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 892   if (buf) Safefree(buf);
 893   if (seenhv) SvREFCNT_dec(seenhv);
 894   MUTEX_UNLOCK(&primenv_mutex);
 895   return;
 896
 897 }  /* end of prime_env_iter */
 898 /*}}}*/
 899
 900
 901 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 902 /* Define or delete an element in the same "environment" as
 903  * vmstrnenv().  If an element is to be deleted, it's removed from
 904  * the first place it's found.  If it's to be set, it's set in the
 905  * place designated by the first element of the table vector.
 906  * Like setenv() returns 0 for success, non-zero on error.
 907  */
 908 int
 909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 910 {
 911     const char *cp1;
 912     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 913     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 914     int nseg = 0, j;
 915     unsigned long int retsts, usermode = PSL$C_USER;
 916     struct itmlst_3 *ile, *ilist;
 917     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 918                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 921     $DESCRIPTOR(local,"_LOCAL");
 922
 923     if (!lnm) {
 924         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 925         return SS$_IVLOGNAM;
 926     }
 927
 928     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 929       *cp2 = _toupper(*cp1);
 930       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 931         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 932         return SS$_IVLOGNAM;
 933       }
 934     }
 935     lnmdsc.dsc$w_length = cp1 - lnm;
 936     if (!tabvec || !*tabvec) tabvec = env_tables;
 937
 938     if (!eqv) {  /* we're deleting n element */
 939       for (curtab = 0; tabvec[curtab]; curtab++) {
 940         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 941         int i;
 942           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 943             if ((cp1 = strchr(environ[i],'=')) &&
 944                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 945                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 946 #ifdef HAS_SETENV
 947               return setenv(lnm,"",1) ? vaxc$errno : 0;
 948             }
 949           }
 950           ivenv = 1; retsts = SS$_NOLOGNAM;
 951 #else
 952               if (ckWARN(WARN_INTERNAL))
 953                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 954               ivenv = 1; retsts = SS$_NOSUCHPGM;
 955               break;
 956             }
 957           }
 958 #endif
 959         }
 960         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 961                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 962           unsigned int symtype;
 963           if (tabvec[curtab]->dsc$w_length == 12 &&
 964               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 965               !str$case_blind_compare(&tmpdsc,&local))
 966             symtype = LIB$K_CLI_LOCAL_SYM;
 967           else symtype = LIB$K_CLI_GLOBAL_SYM;
 968           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 969           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 970           if (retsts == LIB$_NOSUCHSYM) continue;
 971           break;
 972         }
 973         else if (!ivlnm) {
 974           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 975           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 976           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 977           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 978           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 979         }
 980       }
 981     }
 982     else {  /* we're defining a value */
 983       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 984 #ifdef HAS_SETENV
 985         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 986 #else
 987         if (ckWARN(WARN_INTERNAL))
 988           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 989         retsts = SS$_NOSUCHPGM;
 990 #endif
 991       }
 992       else {
 993         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 994         eqvdsc.dsc$w_length  = strlen(eqv);
 995         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 996             !str$case_blind_compare(&tmpdsc,&clisym)) {
 997           unsigned int symtype;
 998           if (tabvec[0]->dsc$w_length == 12 &&
 999               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000                !str$case_blind_compare(&tmpdsc,&local))
1001             symtype = LIB$K_CLI_LOCAL_SYM;
1002           else symtype = LIB$K_CLI_GLOBAL_SYM;
1003           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1004         }
1005         else {
1006           if (!*eqv) eqvdsc.dsc$w_length = 1;
1007           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1008
1009             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1015             }
1016
1017             Newx(ilist,nseg+1,struct itmlst_3);
1018             ile = ilist;
1019             if (!ile) {
1020               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1021               return SS$_INSFMEM;
1022             }
1023             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1024
1025             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026               ile->itmcode = LNM$_STRING;
1027               ile->bufadr = c;
1028               if ((j+1) == nseg) {
1029                 ile->buflen = strlen(c);
1030                 /* in case we are truncating one that's too long */
1031                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1032               }
1033               else {
1034                 ile->buflen = LNM$C_NAMLENGTH;
1035               }
1036             }
1037
1038             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1039             Safefree (ilist);
1040           }
1041           else {
1042             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1043           }
1044         }
1045       }
1046     }
1047     if (!(retsts & 1)) {
1048       switch (retsts) {
1049         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051           set_errno(EVMSERR); break;
1052         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054           set_errno(EINVAL); break;
1055         case SS$_NOPRIV:
1056           set_errno(EACCES);
1057         default:
1058           _ckvmssts(retsts);
1059           set_errno(EVMSERR);
1060        }
1061        set_vaxc_errno(retsts);
1062        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1063     }
1064     else {
1065       /* We reset error values on success because Perl does an hv_fetch()
1066        * before each hv_store(), and if the thing we're setting didn't
1067        * previously exist, we've got a leftover error message.  (Of course,
1068        * this fails in the face of
1069        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070        * in that the error reported in $! isn't spurious,
1071        * but it's right more often than not.)
1072        */
1073       set_errno(0); set_vaxc_errno(retsts);
1074       return 0;
1075     }
1076
1077 }  /* end of vmssetenv() */
1078 /*}}}*/
1079
1080 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1082 void
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1084 {
1085     if (lnm && *lnm) {
1086       int len = strlen(lnm);
1087       if  (len == 7) {
1088         char uplnm[8];
1089         int i;
1090         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091         if (!strcmp(uplnm,"DEFAULT")) {
1092           if (eqv && *eqv) my_chdir(eqv);
1093           return;
1094         }
1095     }
1096 #ifndef RTL_USES_UTC
1097     if (len == 6 || len == 2) {
1098       char uplnm[7];
1099       int i;
1100       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1101       uplnm[len] = '\0';
1102       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1104     }
1105 #endif
1106   }
1107   (void) vmssetenv(lnm,eqv,NULL);
1108 }
1109 /*}}}*/
1110
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1112 /*  vmssetuserlnm
1113  *  sets a user-mode logical in the process logical name table
1114  *  used for redirection of sys$error
1115  */
1116 void
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1118 {
1119     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121     unsigned long int iss, attr = LNM$M_CONFINE;
1122     unsigned char acmode = PSL$C_USER;
1123     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1124                                  {0, 0, 0, 0}};
1125     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126     d_name.dsc$w_length = strlen(name);
1127
1128     lnmlst[0].buflen = strlen(eqv);
1129     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1130
1131     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132     if (!(iss&1)) lib$signal(iss);
1133 }
1134 /*}}}*/
1135
1136
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139  * my_crypt() provides an interface compatible with the Unix crypt()
1140  * C library function, and uses sys$hash_password() to perform VMS
1141  * password hashing.  The quadword hashed password value is returned
1142  * as a NUL-terminated 8 character string.  my_crypt() does not change
1143  * the case of its string arguments; in order to match the behavior
1144  * of LOGINOUT et al., alphabetic characters in both arguments must
1145  *  be upcased by the caller.
1146  *
1147  * - fix me to call ACM services when available
1148  */
1149 char *
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1151 {
1152 #   ifndef UAI$C_PREFERRED_ALGORITHM
1153 #     define UAI$C_PREFERRED_ALGORITHM 127
1154 #   endif
1155     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156     unsigned short int salt = 0;
1157     unsigned long int sts;
1158     struct const_dsc {
1159         unsigned short int dsc$w_length;
1160         unsigned char      dsc$b_type;
1161         unsigned char      dsc$b_class;
1162         const char *       dsc$a_pointer;
1163     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165     struct itmlst_3 uailst[3] = {
1166         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1167         { sizeof salt, UAI$_SALT,    &salt, 0},
1168         { 0,           0,            NULL,  NULL}};
1169     static char hash[9];
1170
1171     usrdsc.dsc$w_length = strlen(usrname);
1172     usrdsc.dsc$a_pointer = usrname;
1173     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1174       switch (sts) {
1175         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1176           set_errno(EACCES);
1177           break;
1178         case RMS$_RNF:
1179           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1180           break;
1181         default:
1182           set_errno(EVMSERR);
1183       }
1184       set_vaxc_errno(sts);
1185       if (sts != RMS$_RNF) return NULL;
1186     }
1187
1188     txtdsc.dsc$w_length = strlen(textpasswd);
1189     txtdsc.dsc$a_pointer = textpasswd;
1190     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1192     }
1193
1194     return (char *) hash;
1195
1196 }  /* end of my_crypt() */
1197 /*}}}*/
1198
1199
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1203
1204 /* fixup barenames that are directories for internal use.
1205  * There have been problems with the consistent handling of UNIX
1206  * style directory names when routines are presented with a name that
1207  * has no directory delimitors at all.  So this routine will eventually
1208  * fix the issue.
1209  */
1210 static char * fixup_bare_dirnames(const char * name)
1211 {
1212   if (decc_disable_to_vms_logname_translation) {
1213 /* fix me */
1214   }
1215   return NULL;
1216 }
1217
1218 /* mp_do_kill_file
1219  * A little hack to get around a bug in some implemenation of remove()
1220  * that do not know how to delete a directory
1221  *
1222  * Delete any file to which user has control access, regardless of whether
1223  * delete access is explicitly allowed.
1224  * Limitations: User must have write access to parent directory.
1225  *              Does not block signals or ASTs; if interrupted in midstream
1226  *              may leave file with an altered ACL.
1227  * HANDLE WITH CARE!
1228  */
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1230 static int
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1232 {
1233     char *vmsname, *rspec;
1234     char *remove_name;
1235     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1238     struct myacedef {
1239       unsigned char myace$b_length;
1240       unsigned char myace$b_type;
1241       unsigned short int myace$w_flags;
1242       unsigned long int myace$l_access;
1243       unsigned long int myace$l_ident;
1244     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1247      struct itmlst_3
1248        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1250        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1254
1255     /* Expand the input spec using RMS, since the CRTL remove() and
1256      * system services won't do this by themselves, so we may miss
1257      * a file "hiding" behind a logical name or search list. */
1258     Newx(vmsname, NAM$C_MAXRSS+1, char);
1259     if (do_tovmsspec(name,vmsname,0) == NULL) {
1260       Safefree(vmsname);
1261       return -1;
1262     }
1263
1264     if (decc_posix_compliant_pathnames) {
1265       /* In POSIX mode, we prefer to remove the UNIX name */
1266       rspec = vmsname;
1267       remove_name = (char *)name;
1268     }
1269     else {
1270       Newx(rspec, NAM$C_MAXRSS+1, char);
1271       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1272         Safefree(rspec);
1273         Safefree(vmsname);
1274         return -1;
1275       }
1276       Safefree(vmsname);
1277       remove_name = rspec;
1278     }
1279
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1281     if (dirflag != 0) {
1282         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283           Newx(remove_name, NAM$C_MAXRSS+1, char);
1284           do_pathify_dirspec(name, remove_name, 0);
1285           if (!rmdir(remove_name)) {
1286
1287             Safefree(remove_name);
1288             Safefree(rspec);
1289             return 0;   /* Can we just get rid of it? */
1290           }
1291         }
1292         else {
1293           if (!rmdir(remove_name)) {
1294             Safefree(rspec);
1295             return 0;   /* Can we just get rid of it? */
1296           }
1297         }
1298     }
1299     else
1300 #endif
1301       if (!remove(remove_name)) {
1302         Safefree(rspec);
1303         return 0;   /* Can we just get rid of it? */
1304       }
1305
1306     /* If not, can changing protections help? */
1307     if (vaxc$errno != RMS$_PRV) {
1308       Safefree(rspec);
1309       return -1;
1310     }
1311
1312     /* No, so we get our own UIC to use as a rights identifier,
1313      * and the insert an ACE at the head of the ACL which allows us
1314      * to delete the file.
1315      */
1316     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317     fildsc.dsc$w_length = strlen(rspec);
1318     fildsc.dsc$a_pointer = rspec;
1319     cxt = 0;
1320     newace.myace$l_ident = oldace.myace$l_ident;
1321     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1322       switch (aclsts) {
1323         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324           set_errno(ENOENT); break;
1325         case RMS$_DIR:
1326           set_errno(ENOTDIR); break;
1327         case RMS$_DEV:
1328           set_errno(ENODEV); break;
1329         case RMS$_SYN: case SS$_INVFILFOROP:
1330           set_errno(EINVAL); break;
1331         case RMS$_PRV:
1332           set_errno(EACCES); break;
1333         default:
1334           _ckvmssts(aclsts);
1335       }
1336       set_vaxc_errno(aclsts);
1337       Safefree(rspec);
1338       return -1;
1339     }
1340     /* Grab any existing ACEs with this identifier in case we fail */
1341     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343                     || fndsts == SS$_NOMOREACE ) {
1344       /* Add the new ACE . . . */
1345       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1346         goto yourroom;
1347
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1349       if (dirflag != 0)
1350         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351           Newx(remove_name, NAM$C_MAXRSS+1, char);
1352           do_pathify_dirspec(name, remove_name, 0);
1353           rmsts = rmdir(remove_name);
1354           Safefree(remove_name);
1355         }
1356         else {
1357         rmsts = rmdir(remove_name);
1358         }
1359       else
1360 #endif
1361         rmsts = remove(remove_name);
1362       if (rmsts) {
1363         /* We blew it - dir with files in it, no write priv for
1364          * parent directory, etc.  Put things back the way they were. */
1365         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1366           goto yourroom;
1367         if (fndsts & 1) {
1368           addlst[0].bufadr = &oldace;
1369           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1370             goto yourroom;
1371         }
1372       }
1373     }
1374
1375     yourroom:
1376     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377     /* We just deleted it, so of course it's not there.  Some versions of
1378      * VMS seem to return success on the unlock operation anyhow (after all
1379      * the unlock is successful), but others don't.
1380      */
1381     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382     if (aclsts & 1) aclsts = fndsts;
1383     if (!(aclsts & 1)) {
1384       set_errno(EVMSERR);
1385       set_vaxc_errno(aclsts);
1386       Safefree(rspec);
1387       return -1;
1388     }
1389
1390     Safefree(rspec);
1391     return rmsts;
1392
1393 }  /* end of kill_file() */
1394 /*}}}*/
1395
1396
1397 /*{{{int do_rmdir(char *name)*/
1398 int
1399 Perl_do_rmdir(pTHX_ const char *name)
1400 {
1401     char dirfile[NAM$C_MAXRSS+1];
1402     int retval;
1403     Stat_t st;
1404
1405     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1408     return retval;
1409
1410 }  /* end of do_rmdir */
1411 /*}}}*/
1412
1413 /* kill_file
1414  * Delete any file to which user has control access, regardless of whether
1415  * delete access is explicitly allowed.
1416  * Limitations: User must have write access to parent directory.
1417  *              Does not block signals or ASTs; if interrupted in midstream
1418  *              may leave file with an altered ACL.
1419  * HANDLE WITH CARE!
1420  */
1421 /*{{{int kill_file(char *name)*/
1422 int
1423 Perl_kill_file(pTHX_ const char *name)
1424 {
1425     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1429     struct myacedef {
1430       unsigned char myace$b_length;
1431       unsigned char myace$b_type;
1432       unsigned short int myace$w_flags;
1433       unsigned long int myace$l_access;
1434       unsigned long int myace$l_ident;
1435     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1438      struct itmlst_3
1439        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1441        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1445
1446     /* Expand the input spec using RMS, since the CRTL remove() and
1447      * system services won't do this by themselves, so we may miss
1448      * a file "hiding" behind a logical name or search list. */
1449     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1452     /* If not, can changing protections help? */
1453     if (vaxc$errno != RMS$_PRV) return -1;
1454
1455     /* No, so we get our own UIC to use as a rights identifier,
1456      * and the insert an ACE at the head of the ACL which allows us
1457      * to delete the file.
1458      */
1459     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460     fildsc.dsc$w_length = strlen(rspec);
1461     fildsc.dsc$a_pointer = rspec;
1462     cxt = 0;
1463     newace.myace$l_ident = oldace.myace$l_ident;
1464     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1465       switch (aclsts) {
1466         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467           set_errno(ENOENT); break;
1468         case RMS$_DIR:
1469           set_errno(ENOTDIR); break;
1470         case RMS$_DEV:
1471           set_errno(ENODEV); break;
1472         case RMS$_SYN: case SS$_INVFILFOROP:
1473           set_errno(EINVAL); break;
1474         case RMS$_PRV:
1475           set_errno(EACCES); break;
1476         default:
1477           _ckvmssts(aclsts);
1478       }
1479       set_vaxc_errno(aclsts);
1480       return -1;
1481     }
1482     /* Grab any existing ACEs with this identifier in case we fail */
1483     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485                     || fndsts == SS$_NOMOREACE ) {
1486       /* Add the new ACE . . . */
1487       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1488         goto yourroom;
1489       if ((rmsts = remove(name))) {
1490         /* We blew it - dir with files in it, no write priv for
1491          * parent directory, etc.  Put things back the way they were. */
1492         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1493           goto yourroom;
1494         if (fndsts & 1) {
1495           addlst[0].bufadr = &oldace;
1496           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1497             goto yourroom;
1498         }
1499       }
1500     }
1501
1502     yourroom:
1503     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504     /* We just deleted it, so of course it's not there.  Some versions of
1505      * VMS seem to return success on the unlock operation anyhow (after all
1506      * the unlock is successful), but others don't.
1507      */
1508     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509     if (aclsts & 1) aclsts = fndsts;
1510     if (!(aclsts & 1)) {
1511       set_errno(EVMSERR);
1512       set_vaxc_errno(aclsts);
1513       return -1;
1514     }
1515
1516     return rmsts;
1517
1518 }  /* end of kill_file() */
1519 /*}}}*/
1520
1521
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1523 int
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1525 {
1526   STRLEN dirlen = strlen(dir);
1527
1528   /* zero length string sometimes gives ACCVIO */
1529   if (dirlen == 0) return -1;
1530
1531   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532    * null file name/type.  However, it's commonplace under Unix,
1533    * so we'll allow it for a gain in portability.
1534    */
1535   if (dir[dirlen-1] == '/') {
1536     char *newdir = savepvn(dir,dirlen-1);
1537     int ret = mkdir(newdir,mode);
1538     Safefree(newdir);
1539     return ret;
1540   }
1541   else return mkdir(dir,mode);
1542 }  /* end of my_mkdir */
1543 /*}}}*/
1544
1545 /*{{{int my_chdir(char *)*/
1546 int
1547 Perl_my_chdir(pTHX_ const char *dir)
1548 {
1549   STRLEN dirlen = strlen(dir);
1550
1551   /* zero length string sometimes gives ACCVIO */
1552   if (dirlen == 0) return -1;
1553   const char *dir1;
1554
1555   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1557    * so that existing scripts do not need to be changed.
1558    */
1559   dir1 = dir;
1560   while ((dirlen > 0) && (*dir1 == ' ')) {
1561     dir1++;
1562     dirlen--;
1563   }
1564
1565   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1566    * that implies
1567    * null file name/type.  However, it's commonplace under Unix,
1568    * so we'll allow it for a gain in portability.
1569    *
1570    * - Preview- '/' will be valid soon on VMS
1571    */
1572   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573     char *newdir = savepvn(dir,dirlen-1);
1574     int ret = chdir(newdir);
1575     Safefree(newdir);
1576     return ret;
1577   }
1578   else return chdir(dir);
1579 }  /* end of my_chdir */
1580 /*}}}*/
1581
1582
1583 /*{{{FILE *my_tmpfile()*/
1584 FILE *
1585 my_tmpfile(void)
1586 {
1587   FILE *fp;
1588   char *cp;
1589
1590   if ((fp = tmpfile())) return fp;
1591
1592   Newx(cp,L_tmpnam+24,char);
1593   if (decc_filename_unix_only == 0)
1594     strcpy(cp,"Sys$Scratch:");
1595   else
1596     strcpy(cp,"/tmp/");
1597   tmpnam(cp+strlen(cp));
1598   strcat(cp,".Perltmp");
1599   fp = fopen(cp,"w+","fop=dlt");
1600   Safefree(cp);
1601   return fp;
1602 }
1603 /*}}}*/
1604
1605
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1607 /*
1608  * The C RTL's sigaction fails to check for invalid signal numbers so we
1609  * help it out a bit.  The docs are correct, but the actual routine doesn't
1610  * do what the docs say it will.
1611  */
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1613 int
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615                    struct sigaction* oact)
1616 {
1617   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618         SETERRNO(EINVAL, SS$_INVARG);
1619         return -1;
1620   }
1621   return sigaction(sig, act, oact);
1622 }
1623 /*}}}*/
1624 #endif
1625
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1628
1629 /* We implement our own kill() using the undocumented system service
1630    sys$sigprc for one of two reasons:
1631
1632    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633    target process to do a sys$exit, which usually can't be handled
1634    gracefully...certainly not by Perl and the %SIG{} mechanism.
1635
1636    2.) If the kill() in the CRTL can't be called from a signal
1637    handler without disappearing into the ether, i.e., the signal
1638    it purportedly sends is never trapped. Still true as of VMS 7.3.
1639
1640    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641    in the target process rather than calling sys$exit.
1642
1643    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1646    with condition codes C$_SIG0+nsig*8, catching the exception on the
1647    target process and resignaling with appropriate arguments.
1648
1649    But we don't have that VMS 7.0+ exception handler, so if you
1650    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1651
1652    Also note that SIGTERM is listed in the docs as being "unimplemented",
1653    yet always seems to be signaled with a VMS condition code of 4 (and
1654    correctly handled for that code).  So we hardwire it in.
1655
1656    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1658    than signalling with an unrecognized (and unhandled by CRTL) code.
1659 */
1660
1661 #define _MY_SIG_MAX 17
1662
1663 unsigned int
1664 Perl_sig_to_vmscondition(int sig)
1665 {
1666     static unsigned int sig_code[_MY_SIG_MAX+1] =
1667     {
1668         0,                  /*  0 ZERO     */
1669         SS$_HANGUP,         /*  1 SIGHUP   */
1670         SS$_CONTROLC,       /*  2 SIGINT   */
1671         SS$_CONTROLY,       /*  3 SIGQUIT  */
1672         SS$_RADRMOD,        /*  4 SIGILL   */
1673         SS$_BREAK,          /*  5 SIGTRAP  */
1674         SS$_OPCCUS,         /*  6 SIGABRT  */
1675         SS$_COMPAT,         /*  7 SIGEMT   */
1676 #ifdef __VAX
1677         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1678 #else
1679         SS$_HPARITH,        /*  8 SIGFPE AXP */
1680 #endif
1681         SS$_ABORT,          /*  9 SIGKILL  */
1682         SS$_ACCVIO,         /* 10 SIGBUS   */
1683         SS$_ACCVIO,         /* 11 SIGSEGV  */
1684         SS$_BADPARAM,       /* 12 SIGSYS   */
1685         SS$_NOMBX,          /* 13 SIGPIPE  */
1686         SS$_ASTFLT,         /* 14 SIGALRM  */
1687         4,                  /* 15 SIGTERM  */
1688         0,                  /* 16 SIGUSR1  */
1689         0                   /* 17 SIGUSR2  */
1690     };
1691
1692 #if __VMS_VER >= 60200000
1693     static int initted = 0;
1694     if (!initted) {
1695         initted = 1;
1696         sig_code[16] = C$_SIGUSR1;
1697         sig_code[17] = C$_SIGUSR2;
1698     }
1699 #endif
1700
1701     if (sig < _SIG_MIN) return 0;
1702     if (sig > _MY_SIG_MAX) return 0;
1703     return sig_code[sig];
1704 }
1705
1706 int
1707 Perl_my_kill(int pid, int sig)
1708 {
1709     dTHX;
1710     int iss;
1711     unsigned int code;
1712     int sys$sigprc(unsigned int *pidadr,
1713                      struct dsc$descriptor_s *prcname,
1714                      unsigned int code);
1715
1716      /* sig 0 means validate the PID */
1717     /*------------------------------*/
1718     if (sig == 0) {
1719         const unsigned long int jpicode = JPI$_PID;
1720         pid_t ret_pid;
1721         int status;
1722         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723         if ($VMS_STATUS_SUCCESS(status))
1724            return 0;
1725         switch (status) {
1726         case SS$_NOSUCHNODE:
1727         case SS$_UNREACHABLE:
1728         case SS$_NONEXPR:
1729            errno = ESRCH;
1730            break;
1731         case SS$_NOPRIV:
1732            errno = EPERM;
1733            break;
1734         default:
1735            errno = EVMSERR;
1736         }
1737         vaxc$errno=status;
1738         return -1;
1739     }
1740
1741     code = Perl_sig_to_vmscondition(sig);
1742
1743     if (!code) {
1744         SETERRNO(EINVAL, SS$_BADPARAM);
1745         return -1;
1746     }
1747
1748     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749      * signals are to be sent to multiple processes.
1750      *  pid = 0 - all processes in group except ones that the system exempts
1751      *  pid = -1 - all processes except ones that the system exempts
1752      *  pid = -n - all processes in group (abs(n)) except ...
1753      * For now, just report as not supported.
1754      */
1755
1756     if (pid <= 0) {
1757         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1758         return -1;
1759     }
1760
1761     iss = sys$sigprc((unsigned int *)&pid,0,code);
1762     if (iss&1) return 0;
1763
1764     switch (iss) {
1765       case SS$_NOPRIV:
1766         set_errno(EPERM);  break;
1767       case SS$_NONEXPR:
1768       case SS$_NOSUCHNODE:
1769       case SS$_UNREACHABLE:
1770         set_errno(ESRCH);  break;
1771       case SS$_INSFMEM:
1772         set_errno(ENOMEM); break;
1773       default:
1774         _ckvmssts(iss);
1775         set_errno(EVMSERR);
1776     }
1777     set_vaxc_errno(iss);
1778
1779     return -1;
1780 }
1781 #endif
1782
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1785 ** existing code.
1786 **
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1788 ** success.
1789 **
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1792 **
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1794 ** decoding.
1795 */
1796
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1799 #endif
1800 #ifndef DCL_IVVERB
1801 #define DCL_IVVERB 0x38090
1802 #endif
1803
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1805 {
1806 int facility;
1807 int fac_sp;
1808 int msg_no;
1809 int msg_status;
1810 int unix_status;
1811
1812   /* Assume the best or the worst */
1813   if (vms_status & STS$M_SUCCESS)
1814     unix_status = 0;
1815   else
1816     unix_status = EVMSERR;
1817
1818   msg_status = vms_status & ~STS$M_CONTROL;
1819
1820   facility = vms_status & STS$M_FAC_NO;
1821   fac_sp = vms_status & STS$M_FAC_SP;
1822   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1823
1824   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1825     switch(msg_no) {
1826     case SS$_NORMAL:
1827         unix_status = 0;
1828         break;
1829     case SS$_ACCVIO:
1830         unix_status = EFAULT;
1831         break;
1832     case SS$_DEVOFFLINE:
1833         unix_status = EBUSY;
1834         break;
1835     case SS$_CLEARED:
1836         unix_status = ENOTCONN;
1837         break;
1838     case SS$_IVCHAN:
1839     case SS$_IVLOGNAM:
1840     case SS$_BADPARAM:
1841     case SS$_IVLOGTAB:
1842     case SS$_NOLOGNAM:
1843     case SS$_NOLOGTAB:
1844     case SS$_INVFILFOROP:
1845     case SS$_INVARG:
1846     case SS$_NOSUCHID:
1847     case SS$_IVIDENT:
1848         unix_status = EINVAL;
1849         break;
1850     case SS$_UNSUPPORTED:
1851         unix_status = ENOTSUP;
1852         break;
1853     case SS$_FILACCERR:
1854     case SS$_NOGRPPRV:
1855     case SS$_NOSYSPRV:
1856         unix_status = EACCES;
1857         break;
1858     case SS$_DEVICEFULL:
1859         unix_status = ENOSPC;
1860         break;
1861     case SS$_NOSUCHDEV:
1862         unix_status = ENODEV;
1863         break;
1864     case SS$_NOSUCHFILE:
1865     case SS$_NOSUCHOBJECT:
1866         unix_status = ENOENT;
1867         break;
1868     case SS$_ABORT:                                 /* Fatal case */
1869     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871         unix_status = EINTR;
1872         break;
1873     case SS$_BUFFEROVF:
1874         unix_status = E2BIG;
1875         break;
1876     case SS$_INSFMEM:
1877         unix_status = ENOMEM;
1878         break;
1879     case SS$_NOPRIV:
1880         unix_status = EPERM;
1881         break;
1882     case SS$_NOSUCHNODE:
1883     case SS$_UNREACHABLE:
1884         unix_status = ESRCH;
1885         break;
1886     case SS$_NONEXPR:
1887         unix_status = ECHILD;
1888         break;
1889     default:
1890         if ((facility == 0) && (msg_no < 8)) {
1891           /* These are not real VMS status codes so assume that they are
1892           ** already UNIX status codes
1893           */
1894           unix_status = msg_no;
1895           break;
1896         }
1897     }
1898   }
1899   else {
1900     /* Translate a POSIX exit code to a UNIX exit code */
1901     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1902         unix_status = (msg_no & 0x07F8) >> 3;
1903     }
1904     else {
1905
1906          /* Documented traditional behavior for handling VMS child exits */
1907         /*--------------------------------------------------------------*/
1908         if (child_flag != 0) {
1909
1910              /* Success / Informational return 0 */
1911             /*----------------------------------*/
1912             if (msg_no & STS$K_SUCCESS)
1913                 return 0;
1914
1915              /* Warning returns 1 */
1916             /*-------------------*/
1917             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1918                 return 1;
1919
1920              /* Everything else pass through the severity bits */
1921             /*------------------------------------------------*/
1922             return (msg_no & STS$M_SEVERITY);
1923         }
1924
1925          /* Normal VMS status to ERRNO mapping attempt */
1926         /*--------------------------------------------*/
1927         switch(msg_status) {
1928         /* case RMS$_EOF: */ /* End of File */
1929         case RMS$_FNF:  /* File Not Found */
1930         case RMS$_DNF:  /* Dir Not Found */
1931                 unix_status = ENOENT;
1932                 break;
1933         case RMS$_RNF:  /* Record Not Found */
1934                 unix_status = ESRCH;
1935                 break;
1936         case RMS$_DIR:
1937                 unix_status = ENOTDIR;
1938                 break;
1939         case RMS$_DEV:
1940                 unix_status = ENODEV;
1941                 break;
1942         case RMS$_IFI:
1943         case RMS$_FAC:
1944         case RMS$_ISI:
1945                 unix_status = EBADF;
1946                 break;
1947         case RMS$_FEX:
1948                 unix_status = EEXIST;
1949                 break;
1950         case RMS$_SYN:
1951         case RMS$_FNM:
1952         case LIB$_INVSTRDES:
1953         case LIB$_INVARG:
1954         case LIB$_NOSUCHSYM:
1955         case LIB$_INVSYMNAM:
1956         case DCL_IVVERB:
1957                 unix_status = EINVAL;
1958                 break;
1959         case CLI$_BUFOVF:
1960         case RMS$_RTB:
1961         case CLI$_TKNOVF:
1962         case CLI$_RSLOVF:
1963                 unix_status = E2BIG;
1964                 break;
1965         case RMS$_PRV:  /* No privilege */
1966         case RMS$_ACC:  /* ACP file access failed */
1967         case RMS$_WLK:  /* Device write locked */
1968                 unix_status = EACCES;
1969                 break;
1970         /* case RMS$_NMF: */  /* No more files */
1971         }
1972     }
1973   }
1974
1975   return unix_status;
1976 }
1977
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979  * value.  This is hard to do as there could be many possible VMS
1980  * error statuses that caused the errno value to be set.
1981  */
1982
1983 int Perl_unix_status_to_vms(int unix_status)
1984 {
1985 int test_unix_status;
1986
1987      /* Trivial cases first */
1988     /*---------------------*/
1989     if (unix_status == EVMSERR)
1990         return vaxc$errno;
1991
1992      /* Is vaxc$errno sane? */
1993     /*---------------------*/
1994     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995     if (test_unix_status == unix_status)
1996         return vaxc$errno;
1997
1998      /* If way out of range, must be VMS code already */
1999     /*-----------------------------------------------*/
2000     if (unix_status > EVMSERR)
2001         return unix_status;
2002
2003      /* If out of range, punt */
2004     /*-----------------------*/
2005     if (unix_status > __ERRNO_MAX)
2006         return SS$_ABORT;
2007
2008
2009      /* Ok, now we have to do it the hard way. */
2010     /*----------------------------------------*/
2011     switch(unix_status) {
2012     case 0:     return SS$_NORMAL;
2013     case EPERM: return SS$_NOPRIV;
2014     case ENOENT: return SS$_NOSUCHOBJECT;
2015     case ESRCH: return SS$_UNREACHABLE;
2016     case EINTR: return SS$_ABORT;
2017     /* case EIO: */
2018     /* case ENXIO:  */
2019     case E2BIG: return SS$_BUFFEROVF;
2020     /* case ENOEXEC */
2021     case EBADF: return RMS$_IFI;
2022     case ECHILD: return SS$_NONEXPR;
2023     /* case EAGAIN */
2024     case ENOMEM: return SS$_INSFMEM;
2025     case EACCES: return SS$_FILACCERR;
2026     case EFAULT: return SS$_ACCVIO;
2027     /* case ENOTBLK */
2028     case EBUSY: return SS$_DEVOFFLINE;
2029     case EEXIST: return RMS$_FEX;
2030     /* case EXDEV */
2031     case ENODEV: return SS$_NOSUCHDEV;
2032     case ENOTDIR: return RMS$_DIR;
2033     /* case EISDIR */
2034     case EINVAL: return SS$_INVARG;
2035     /* case ENFILE */
2036     /* case EMFILE */
2037     /* case ENOTTY */
2038     /* case ETXTBSY */
2039     /* case EFBIG */
2040     case ENOSPC: return SS$_DEVICEFULL;
2041     case ESPIPE: return LIB$_INVARG;
2042     /* case EROFS: */
2043     /* case EMLINK: */
2044     /* case EPIPE: */
2045     /* case EDOM */
2046     case ERANGE: return LIB$_INVARG;
2047     /* case EWOULDBLOCK */
2048     /* case EINPROGRESS */
2049     /* case EALREADY */
2050     /* case ENOTSOCK */
2051     /* case EDESTADDRREQ */
2052     /* case EMSGSIZE */
2053     /* case EPROTOTYPE */
2054     /* case ENOPROTOOPT */
2055     /* case EPROTONOSUPPORT */
2056     /* case ESOCKTNOSUPPORT */
2057     /* case EOPNOTSUPP */
2058     /* case EPFNOSUPPORT */
2059     /* case EAFNOSUPPORT */
2060     /* case EADDRINUSE */
2061     /* case EADDRNOTAVAIL */
2062     /* case ENETDOWN */
2063     /* case ENETUNREACH */
2064     /* case ENETRESET */
2065     /* case ECONNABORTED */
2066     /* case ECONNRESET */
2067     /* case ENOBUFS */
2068     /* case EISCONN */
2069     case ENOTCONN: return SS$_CLEARED;
2070     /* case ESHUTDOWN */
2071     /* case ETOOMANYREFS */
2072     /* case ETIMEDOUT */
2073     /* case ECONNREFUSED */
2074     /* case ELOOP */
2075     /* case ENAMETOOLONG */
2076     /* case EHOSTDOWN */
2077     /* case EHOSTUNREACH */
2078     /* case ENOTEMPTY */
2079     /* case EPROCLIM */
2080     /* case EUSERS  */
2081     /* case EDQUOT  */
2082     /* case ENOMSG  */
2083     /* case EIDRM */
2084     /* case EALIGN */
2085     /* case ESTALE */
2086     /* case EREMOTE */
2087     /* case ENOLCK */
2088     /* case ENOSYS */
2089     /* case EFTYPE */
2090     /* case ECANCELED */
2091     /* case EFAIL */
2092     /* case EINPROG */
2093     case ENOTSUP:
2094         return SS$_UNSUPPORTED;
2095     /* case EDEADLK */
2096     /* case ENWAIT */
2097     /* case EILSEQ */
2098     /* case EBADCAT */
2099     /* case EBADMSG */
2100     /* case EABANDONED */
2101     default:
2102         return SS$_ABORT; /* punt */
2103     }
2104
2105   return SS$_ABORT; /* Should not get here */
2106 }
2107
2108
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ        512
2111
2112
2113 static void
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2115 {
2116   unsigned long int mbxbufsiz;
2117   static unsigned long int syssize = 0;
2118   unsigned long int dviitm = DVI$_DEVNAM;
2119   char csize[LNM$C_NAMLENGTH+1];
2120   int sts;
2121
2122   if (!syssize) {
2123     unsigned long syiitm = SYI$_MAXBUF;
2124     /*
2125      * Get the SYSGEN parameter MAXBUF
2126      *
2127      * If the logical 'PERL_MBX_SIZE' is defined
2128      * use the value of the logical instead of PERL_BUFSIZ, but
2129      * keep the size between 128 and MAXBUF.
2130      *
2131      */
2132     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2133   }
2134
2135   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136       mbxbufsiz = atoi(csize);
2137   } else {
2138       mbxbufsiz = PERL_BUFSIZ;
2139   }
2140   if (mbxbufsiz < 128) mbxbufsiz = 128;
2141   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2142
2143   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2144
2145   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2147
2148 }  /* end of create_mbx() */
2149
2150
2151 /*{{{  my_popen and my_pclose*/
2152
2153 typedef struct _iosb           IOSB;
2154 typedef struct _iosb*         pIOSB;
2155 typedef struct _pipe           Pipe;
2156 typedef struct _pipe*         pPipe;
2157 typedef struct pipe_details    Info;
2158 typedef struct pipe_details*  pInfo;
2159 typedef struct _srqp            RQE;
2160 typedef struct _srqp*          pRQE;
2161 typedef struct _tochildbuf      CBuf;
2162 typedef struct _tochildbuf*    pCBuf;
2163
2164 struct _iosb {
2165     unsigned short status;
2166     unsigned short count;
2167     unsigned long  dvispec;
2168 };
2169
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp {          /* VMS self-relative queue entry */
2173     unsigned long qptr[2];
2174 };
2175 #pragma member_alignment restore
2176 static RQE  RQE_ZERO = {0,0};
2177
2178 struct _tochildbuf {
2179     RQE             q;
2180     int             eof;
2181     unsigned short  size;
2182     char            *buf;
2183 };
2184
2185 struct _pipe {
2186     RQE            free;
2187     RQE            wait;
2188     int            fd_out;
2189     unsigned short chan_in;
2190     unsigned short chan_out;
2191     char          *buf;
2192     unsigned int   bufsize;
2193     IOSB           iosb;
2194     IOSB           iosb2;
2195     int           *pipe_done;
2196     int            retry;
2197     int            type;
2198     int            shut_on_empty;
2199     int            need_wake;
2200     pPipe         *home;
2201     pInfo          info;
2202     pCBuf          curr;
2203     pCBuf          curr2;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205     void            *thx;           /* Either a thread or an interpreter */
2206                                     /* pointer, depending on how we're built */
2207 #endif
2208 };
2209
2210
2211 struct pipe_details
2212 {
2213     pInfo           next;
2214     PerlIO *fp;  /* file pointer to pipe mailbox */
2215     int useFILE; /* using stdio, not perlio */
2216     int pid;   /* PID of subprocess */
2217     int mode;  /* == 'r' if pipe open for reading */
2218     int done;  /* subprocess has completed */
2219     int waiting; /* waiting for completion/closure */
2220     int             closing;        /* my_pclose is closing this pipe */
2221     unsigned long   completion;     /* termination status of subprocess */
2222     pPipe           in;             /* pipe in to sub */
2223     pPipe           out;            /* pipe out of sub */
2224     pPipe           err;            /* pipe of sub's sys$error */
2225     int             in_done;        /* true when in pipe finished */
2226     int             out_done;
2227     int             err_done;
2228 };
2229
2230 struct exit_control_block
2231 {
2232     struct exit_control_block *flink;
2233     unsigned long int   (*exit_routine)();
2234     unsigned long int arg_count;
2235     unsigned long int *status_address;
2236     unsigned long int exit_status;
2237 };
2238
2239 typedef struct _closed_pipes    Xpipe;
2240 typedef struct _closed_pipes*  pXpipe;
2241
2242 struct _closed_pipes {
2243     int             pid;            /* PID of subprocess */
2244     unsigned long   completion;     /* termination status of subprocess */
2245 };
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int   closed_index = 0;
2249 static int   closed_num = 0;
2250
2251 #define RETRY_DELAY     "0 ::0.20"
2252 #define MAX_RETRY              50
2253
2254 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2257
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2260
2261 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2262
2263
2264
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2267 {
2268     pInfo info;
2269     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270     int sts, did_stuff, need_eof, j;
2271
2272     /*
2273         flush any pending i/o
2274     */
2275     info = open_pipes;
2276     while (info) {
2277         if (info->fp) {
2278            if (!info->useFILE)
2279                PerlIO_flush(info->fp);   /* first, flush data */
2280            else
2281                fflush((FILE *)info->fp);
2282         }
2283         info = info->next;
2284     }
2285
2286     /*
2287      next we try sending an EOF...ignore if doesn't work, make sure we
2288      don't hang
2289     */
2290     did_stuff = 0;
2291     info = open_pipes;
2292
2293     while (info) {
2294       int need_eof;
2295       _ckvmssts_noperl(sys$setast(0));
2296       if (info->in && !info->in->shut_on_empty) {
2297         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2298                           0, 0, 0, 0, 0, 0));
2299         info->waiting = 1;
2300         did_stuff = 1;
2301       }
2302       _ckvmssts_noperl(sys$setast(1));
2303       info = info->next;
2304     }
2305
2306     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2307
2308     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2309         int nwait = 0;
2310
2311         info = open_pipes;
2312         while (info) {
2313           _ckvmssts_noperl(sys$setast(0));
2314           if (info->waiting && info->done)
2315                 info->waiting = 0;
2316           nwait += info->waiting;
2317           _ckvmssts_noperl(sys$setast(1));
2318           info = info->next;
2319         }
2320         if (!nwait) break;
2321         sleep(1);
2322     }
2323
2324     did_stuff = 0;
2325     info = open_pipes;
2326     while (info) {
2327       _ckvmssts_noperl(sys$setast(0));
2328       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329         sts = sys$forcex(&info->pid,0,&abort);
2330         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2331         did_stuff = 1;
2332       }
2333       _ckvmssts_noperl(sys$setast(1));
2334       info = info->next;
2335     }
2336
2337     /* again, wait for effect */
2338
2339     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2340         int nwait = 0;
2341
2342         info = open_pipes;
2343         while (info) {
2344           _ckvmssts_noperl(sys$setast(0));
2345           if (info->waiting && info->done)
2346                 info->waiting = 0;
2347           nwait += info->waiting;
2348           _ckvmssts_noperl(sys$setast(1));
2349           info = info->next;
2350         }
2351         if (!nwait) break;
2352         sleep(1);
2353     }
2354
2355     info = open_pipes;
2356     while (info) {
2357       _ckvmssts_noperl(sys$setast(0));
2358       if (!info->done) {  /* We tried to be nice . . . */
2359         sts = sys$delprc(&info->pid,0);
2360         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2361       }
2362       _ckvmssts_noperl(sys$setast(1));
2363       info = info->next;
2364     }
2365
2366     while(open_pipes) {
2367       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368       else if (!(sts & 1)) retsts = sts;
2369     }
2370     return retsts;
2371 }
2372
2373 static struct exit_control_block pipe_exitblock =
2374        {(struct exit_control_block *) 0,
2375         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2376
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2380
2381 static void
2382 popen_completion_ast(pInfo info)
2383 {
2384   pInfo i = open_pipes;
2385   int iss;
2386   int sts;
2387   pXpipe x;
2388
2389   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390   closed_list[closed_index].pid = info->pid;
2391   closed_list[closed_index].completion = info->completion;
2392   closed_index++;
2393   if (closed_index == NKEEPCLOSED)
2394     closed_index = 0;
2395   closed_num++;
2396
2397   while (i) {
2398     if (i == info) break;
2399     i = i->next;
2400   }
2401   if (!i) return;       /* unlinked, probably freed too */
2402
2403   info->done = TRUE;
2404
2405 /*
2406     Writing to subprocess ...
2407             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2408
2409             chan_out may be waiting for "done" flag, or hung waiting
2410             for i/o completion to child...cancel the i/o.  This will
2411             put it into "snarf mode" (done but no EOF yet) that discards
2412             input.
2413
2414     Output from subprocess (stdout, stderr) needs to be flushed and
2415     shut down.   We try sending an EOF, but if the mbx is full the pipe
2416     routine should still catch the "shut_on_empty" flag, telling it to
2417     use immediate-style reads so that "mbx empty" -> EOF.
2418
2419
2420 */
2421   if (info->in && !info->in_done) {               /* only for mode=w */
2422         if (info->in->shut_on_empty && info->in->need_wake) {
2423             info->in->need_wake = FALSE;
2424             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2425         } else {
2426             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2427         }
2428   }
2429
2430   if (info->out && !info->out_done) {             /* were we also piping output? */
2431       info->out->shut_on_empty = TRUE;
2432       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434       _ckvmssts_noperl(iss);
2435   }
2436
2437   if (info->err && !info->err_done) {        /* we were piping stderr */
2438         info->err->shut_on_empty = TRUE;
2439         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441         _ckvmssts_noperl(iss);
2442   }
2443   _ckvmssts_noperl(sys$setef(pipe_ef));
2444
2445 }
2446
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2449
2450 /*
2451     we actually differ from vmstrnenv since we use this to
2452     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453     are pointing to the same thing
2454 */
2455
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2458 {
2459     int iss;
2460     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461     $DESCRIPTOR(d_log,"");
2462     struct _il3 {
2463         unsigned short length;
2464         unsigned short code;
2465         char *         buffer_addr;
2466         unsigned short *retlenaddr;
2467     } itmlst[2];
2468     unsigned short l, ifi;
2469
2470     d_log.dsc$a_pointer = logical;
2471     d_log.dsc$w_length  = strlen(logical);
2472
2473     itmlst[0].code = LNM$_STRING;
2474     itmlst[0].length = 255;
2475     itmlst[0].buffer_addr = result;
2476     itmlst[0].retlenaddr = &l;
2477
2478     itmlst[1].code = 0;
2479     itmlst[1].length = 0;
2480     itmlst[1].buffer_addr = 0;
2481     itmlst[1].retlenaddr = 0;
2482
2483     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484     if (iss == SS$_NOLOGNAM) {
2485         iss = SS$_NORMAL;
2486         l = 0;
2487     }
2488     if (!(iss&1)) lib$signal(iss);
2489     result[l] = '\0';
2490 /*
2491     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2492     strip it off and return the ifi, if any
2493 */
2494     ifi  = 0;
2495     if (result[0] == 0x1b && result[1] == 0x00) {
2496         memmove(&ifi,result+2,2);
2497         strcpy(result,result+4);
2498     }
2499     return ifi;     /* this is the RMS internal file id */
2500 }
2501
2502 static void pipe_infromchild_ast(pPipe p);
2503
2504 /*
2505     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506     inside an AST routine without worrying about reentrancy and which Perl
2507     memory allocator is being used.
2508
2509     We read data and queue up the buffers, then spit them out one at a
2510     time to the output mailbox when the output mailbox is ready for one.
2511
2512 */
2513 #define INITIAL_TOCHILDQUEUE  2
2514
2515 static pPipe
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2517 {
2518     pPipe p;
2519     pCBuf b;
2520     char mbx1[64], mbx2[64];
2521     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522                                       DSC$K_CLASS_S, mbx1},
2523                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524                                       DSC$K_CLASS_S, mbx2};
2525     unsigned int dviitm = DVI$_DEVBUFSIZ;
2526     int j, n;
2527
2528     n = sizeof(Pipe);
2529     _ckvmssts(lib$get_vm(&n, &p));
2530
2531     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2532     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2533     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2534
2535     p->buf           = 0;
2536     p->shut_on_empty = FALSE;
2537     p->need_wake     = FALSE;
2538     p->type          = 0;
2539     p->retry         = 0;
2540     p->iosb.status   = SS$_NORMAL;
2541     p->iosb2.status  = SS$_NORMAL;
2542     p->free          = RQE_ZERO;
2543     p->wait          = RQE_ZERO;
2544     p->curr          = 0;
2545     p->curr2         = 0;
2546     p->info          = 0;
2547 #ifdef PERL_IMPLICIT_CONTEXT
2548     p->thx           = aTHX;
2549 #endif
2550
2551     n = sizeof(CBuf) + p->bufsize;
2552
2553     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2554         _ckvmssts(lib$get_vm(&n, &b));
2555         b->buf = (char *) b + sizeof(CBuf);
2556         _ckvmssts(lib$insqhi(b, &p->free));
2557     }
2558
2559     pipe_tochild2_ast(p);
2560     pipe_tochild1_ast(p);
2561     strcpy(wmbx, mbx1);
2562     strcpy(rmbx, mbx2);
2563     return p;
2564 }
2565
2566 /*  reads the MBX Perl is writing, and queues */
2567
2568 static void
2569 pipe_tochild1_ast(pPipe p)
2570 {
2571     pCBuf b = p->curr;
2572     int iss = p->iosb.status;
2573     int eof = (iss == SS$_ENDOFFILE);
2574     int sts;
2575 #ifdef PERL_IMPLICIT_CONTEXT
2576     pTHX = p->thx;
2577 #endif
2578
2579     if (p->retry) {
2580         if (eof) {
2581             p->shut_on_empty = TRUE;
2582             b->eof     = TRUE;
2583             _ckvmssts(sys$dassgn(p->chan_in));
2584         } else  {
2585             _ckvmssts(iss);
2586         }
2587
2588         b->eof  = eof;
2589         b->size = p->iosb.count;
2590         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2591         if (p->need_wake) {
2592             p->need_wake = FALSE;
2593             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2594         }
2595     } else {
2596         p->retry = 1;   /* initial call */
2597     }
2598
2599     if (eof) {                  /* flush the free queue, return when done */
2600         int n = sizeof(CBuf) + p->bufsize;
2601         while (1) {
2602             iss = lib$remqti(&p->free, &b);
2603             if (iss == LIB$_QUEWASEMP) return;
2604             _ckvmssts(iss);
2605             _ckvmssts(lib$free_vm(&n, &b));
2606         }
2607     }
2608
2609     iss = lib$remqti(&p->free, &b);
2610     if (iss == LIB$_QUEWASEMP) {
2611         int n = sizeof(CBuf) + p->bufsize;
2612         _ckvmssts(lib$get_vm(&n, &b));
2613         b->buf = (char *) b + sizeof(CBuf);
2614     } else {
2615        _ckvmssts(iss);
2616     }
2617
2618     p->curr = b;
2619     iss = sys$qio(0,p->chan_in,
2620              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2621              &p->iosb,
2622              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2623     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2624     _ckvmssts(iss);
2625 }
2626
2627
2628 /* writes queued buffers to output, waits for each to complete before
2629    doing the next */
2630
2631 static void
2632 pipe_tochild2_ast(pPipe p)
2633 {
2634     pCBuf b = p->curr2;
2635     int iss = p->iosb2.status;
2636     int n = sizeof(CBuf) + p->bufsize;
2637     int done = (p->info && p->info->done) ||
2638               iss == SS$_CANCEL || iss == SS$_ABORT;
2639 #if defined(PERL_IMPLICIT_CONTEXT)
2640     pTHX = p->thx;
2641 #endif
2642
2643     do {
2644         if (p->type) {         /* type=1 has old buffer, dispose */
2645             if (p->shut_on_empty) {
2646                 _ckvmssts(lib$free_vm(&n, &b));
2647             } else {
2648                 _ckvmssts(lib$insqhi(b, &p->free));
2649             }
2650             p->type = 0;
2651         }
2652
2653         iss = lib$remqti(&p->wait, &b);
2654         if (iss == LIB$_QUEWASEMP) {
2655             if (p->shut_on_empty) {
2656                 if (done) {
2657                     _ckvmssts(sys$dassgn(p->chan_out));
2658                     *p->pipe_done = TRUE;
2659                     _ckvmssts(sys$setef(pipe_ef));
2660                 } else {
2661                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2662                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2663                 }
2664                 return;
2665             }
2666             p->need_wake = TRUE;
2667             return;
2668         }
2669         _ckvmssts(iss);
2670         p->type = 1;
2671     } while (done);
2672
2673
2674     p->curr2 = b;
2675     if (b->eof) {
2676         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2677             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2678     } else {
2679         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2680             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2681     }
2682
2683     return;
2684
2685 }
2686
2687
2688 static pPipe
2689 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2690 {
2691     pPipe p;
2692     char mbx1[64], mbx2[64];
2693     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2694                                       DSC$K_CLASS_S, mbx1},
2695                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2696                                       DSC$K_CLASS_S, mbx2};
2697     unsigned int dviitm = DVI$_DEVBUFSIZ;
2698
2699     int n = sizeof(Pipe);
2700     _ckvmssts(lib$get_vm(&n, &p));
2701     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2702     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2703
2704     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2705     n = p->bufsize * sizeof(char);
2706     _ckvmssts(lib$get_vm(&n, &p->buf));
2707     p->shut_on_empty = FALSE;
2708     p->info   = 0;
2709     p->type   = 0;
2710     p->iosb.status = SS$_NORMAL;
2711 #if defined(PERL_IMPLICIT_CONTEXT)
2712     p->thx = aTHX;
2713 #endif
2714     pipe_infromchild_ast(p);
2715
2716     strcpy(wmbx, mbx1);
2717     strcpy(rmbx, mbx2);
2718     return p;
2719 }
2720
2721 static void
2722 pipe_infromchild_ast(pPipe p)
2723 {
2724     int iss = p->iosb.status;
2725     int eof = (iss == SS$_ENDOFFILE);
2726     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2727     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2728 #if defined(PERL_IMPLICIT_CONTEXT)
2729     pTHX = p->thx;
2730 #endif
2731
2732     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2733         _ckvmssts(sys$dassgn(p->chan_out));
2734         p->chan_out = 0;
2735     }
2736
2737     /* read completed:
2738             input shutdown if EOF from self (done or shut_on_empty)
2739             output shutdown if closing flag set (my_pclose)
2740             send data/eof from child or eof from self
2741             otherwise, re-read (snarf of data from child)
2742     */
2743
2744     if (p->type == 1) {
2745         p->type = 0;
2746         if (myeof && p->chan_in) {                  /* input shutdown */
2747             _ckvmssts(sys$dassgn(p->chan_in));
2748             p->chan_in = 0;
2749         }
2750
2751         if (p->chan_out) {
2752             if (myeof || kideof) {      /* pass EOF to parent */
2753                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2754                               pipe_infromchild_ast, p,
2755                               0, 0, 0, 0, 0, 0));
2756                 return;
2757             } else if (eof) {       /* eat EOF --- fall through to read*/
2758
2759             } else {                /* transmit data */
2760                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2761                               pipe_infromchild_ast,p,
2762                               p->buf, p->iosb.count, 0, 0, 0, 0));
2763                 return;
2764             }
2765         }
2766     }
2767
2768     /*  everything shut? flag as done */
2769
2770     if (!p->chan_in && !p->chan_out) {
2771         *p->pipe_done = TRUE;
2772         _ckvmssts(sys$setef(pipe_ef));
2773         return;
2774     }
2775
2776     /* write completed (or read, if snarfing from child)
2777             if still have input active,
2778                queue read...immediate mode if shut_on_empty so we get EOF if empty
2779             otherwise,
2780                check if Perl reading, generate EOFs as needed
2781     */
2782
2783     if (p->type == 0) {
2784         p->type = 1;
2785         if (p->chan_in) {
2786             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2787                           pipe_infromchild_ast,p,
2788                           p->buf, p->bufsize, 0, 0, 0, 0);
2789             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2790             _ckvmssts(iss);
2791         } else {           /* send EOFs for extra reads */
2792             p->iosb.status = SS$_ENDOFFILE;
2793             p->iosb.dvispec = 0;
2794             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2795                       0, 0, 0,
2796                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2797         }
2798     }
2799 }
2800
2801 static pPipe
2802 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2803 {
2804     pPipe p;
2805     char mbx[64];
2806     unsigned long dviitm = DVI$_DEVBUFSIZ;
2807     struct stat s;
2808     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2809                                       DSC$K_CLASS_S, mbx};
2810     int n = sizeof(Pipe);
2811
2812     /* things like terminals and mbx's don't need this filter */
2813     if (fd && fstat(fd,&s) == 0) {
2814         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2815         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2816                                          DSC$K_CLASS_S, s.st_dev};
2817
2818         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2819         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2820             strcpy(out, s.st_dev);
2821             return 0;
2822         }
2823     }
2824
2825     _ckvmssts(lib$get_vm(&n, &p));
2826     p->fd_out = dup(fd);
2827     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2828     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2829     n = (p->bufsize+1) * sizeof(char);
2830     _ckvmssts(lib$get_vm(&n, &p->buf));
2831     p->shut_on_empty = FALSE;
2832     p->retry = 0;
2833     p->info  = 0;
2834     strcpy(out, mbx);
2835
2836     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2837                   pipe_mbxtofd_ast, p,
2838                   p->buf, p->bufsize, 0, 0, 0, 0));
2839
2840     return p;
2841 }
2842
2843 static void
2844 pipe_mbxtofd_ast(pPipe p)
2845 {
2846     int iss = p->iosb.status;
2847     int done = p->info->done;
2848     int iss2;
2849     int eof = (iss == SS$_ENDOFFILE);
2850     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2851     int err = !(iss&1) && !eof;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2853     pTHX = p->thx;
2854 #endif
2855
2856     if (done && myeof) {               /* end piping */
2857         close(p->fd_out);
2858         sys$dassgn(p->chan_in);
2859         *p->pipe_done = TRUE;
2860         _ckvmssts(sys$setef(pipe_ef));
2861         return;
2862     }
2863
2864     if (!err && !eof) {             /* good data to send to file */
2865         p->buf[p->iosb.count] = '\n';
2866         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2867         if (iss2 < 0) {
2868             p->retry++;
2869             if (p->retry < MAX_RETRY) {
2870                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2871                 return;
2872             }
2873         }
2874         p->retry = 0;
2875     } else if (err) {
2876         _ckvmssts(iss);
2877     }
2878
2879
2880     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2881           pipe_mbxtofd_ast, p,
2882           p->buf, p->bufsize, 0, 0, 0, 0);
2883     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2884     _ckvmssts(iss);
2885 }
2886
2887
2888 typedef struct _pipeloc     PLOC;
2889 typedef struct _pipeloc*   pPLOC;
2890
2891 struct _pipeloc {
2892     pPLOC   next;
2893     char    dir[NAM$C_MAXRSS+1];
2894 };
2895 static pPLOC  head_PLOC = 0;
2896
2897 void
2898 free_pipelocs(pTHX_ void *head)
2899 {
2900     pPLOC p, pnext;
2901     pPLOC *pHead = (pPLOC *)head;
2902
2903     p = *pHead;
2904     while (p) {
2905         pnext = p->next;
2906         PerlMem_free(p);
2907         p = pnext;
2908     }
2909     *pHead = 0;
2910 }
2911
2912 static void
2913 store_pipelocs(pTHX)
2914 {
2915     int    i;
2916     pPLOC  p;
2917     AV    *av = 0;
2918     SV    *dirsv;
2919     GV    *gv;
2920     char  *dir, *x;
2921     char  *unixdir;
2922     char  temp[NAM$C_MAXRSS+1];
2923     STRLEN n_a;
2924
2925     if (head_PLOC)
2926         free_pipelocs(aTHX_ &head_PLOC);
2927
2928 /*  the . directory from @INC comes last */
2929
2930     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2931     p->next = head_PLOC;
2932     head_PLOC = p;
2933     strcpy(p->dir,"./");
2934
2935 /*  get the directory from $^X */
2936
2937 #ifdef PERL_IMPLICIT_CONTEXT
2938     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2939 #else
2940     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2941 #endif
2942         strcpy(temp, PL_origargv[0]);
2943         x = strrchr(temp,']');
2944         if (x == NULL) {
2945         x = strrchr(temp,'>');
2946           if (x == NULL) {
2947             /* It could be a UNIX path */
2948             x = strrchr(temp,'/');
2949           }
2950         }
2951         if (x)
2952           x[1] = '\0';
2953         else {
2954           /* Got a bare name, so use default directory */
2955           temp[0] = '.';
2956           temp[1] = '\0';
2957         }
2958
2959         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2960             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2961             p->next = head_PLOC;
2962             head_PLOC = p;
2963             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2964             p->dir[NAM$C_MAXRSS] = '\0';
2965         }
2966     }
2967
2968 /*  reverse order of @INC entries, skip "." since entered above */
2969
2970 #ifdef PERL_IMPLICIT_CONTEXT
2971     if (aTHX)
2972 #endif
2973     if (PL_incgv) av = GvAVn(PL_incgv);
2974
2975     for (i = 0; av && i <= AvFILL(av); i++) {
2976         dirsv = *av_fetch(av,i,TRUE);
2977
2978         if (SvROK(dirsv)) continue;
2979         dir = SvPVx(dirsv,n_a);
2980         if (strcmp(dir,".") == 0) continue;
2981         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2982             continue;
2983
2984         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2985         p->next = head_PLOC;
2986         head_PLOC = p;
2987         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2988         p->dir[NAM$C_MAXRSS] = '\0';
2989     }
2990
2991 /* most likely spot (ARCHLIB) put first in the list */
2992
2993 #ifdef ARCHLIB_EXP
2994     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2995         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2996         p->next = head_PLOC;
2997         head_PLOC = p;
2998         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2999         p->dir[NAM$C_MAXRSS] = '\0';
3000     }
3001 #endif
3002 }
3003
3004
3005 static char *
3006 find_vmspipe(pTHX)
3007 {
3008     static int   vmspipe_file_status = 0;
3009     static char  vmspipe_file[NAM$C_MAXRSS+1];
3010
3011     /* already found? Check and use ... need read+execute permission */
3012
3013     if (vmspipe_file_status == 1) {
3014         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3015          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3016             return vmspipe_file;
3017         }
3018         vmspipe_file_status = 0;
3019     }
3020
3021     /* scan through stored @INC, $^X */
3022
3023     if (vmspipe_file_status == 0) {
3024         char file[NAM$C_MAXRSS+1];
3025         pPLOC  p = head_PLOC;
3026
3027         while (p) {
3028             strcpy(file, p->dir);
3029             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3030             file[NAM$C_MAXRSS] = '\0';
3031             p = p->next;
3032
3033             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3034
3035             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3036              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3037                 vmspipe_file_status = 1;
3038                 return vmspipe_file;
3039             }
3040         }
3041         vmspipe_file_status = -1;   /* failed, use tempfiles */
3042     }
3043
3044     return 0;
3045 }
3046
3047 static FILE *
3048 vmspipe_tempfile(pTHX)
3049 {
3050     char file[NAM$C_MAXRSS+1];
3051     FILE *fp;
3052     static int index = 0;
3053     Stat_t s0, s1;
3054     int cmp_result;
3055
3056     /* create a tempfile */
3057
3058     /* we can't go from   W, shr=get to  R, shr=get without
3059        an intermediate vulnerable state, so don't bother trying...
3060
3061        and lib$spawn doesn't shr=put, so have to close the write
3062
3063        So... match up the creation date/time and the FID to
3064        make sure we're dealing with the same file
3065
3066     */
3067
3068     index++;
3069     if (!decc_filename_unix_only) {
3070       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3071       fp = fopen(file,"w");
3072       if (!fp) {
3073         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3074         fp = fopen(file,"w");
3075         if (!fp) {
3076             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3077             fp = fopen(file,"w");
3078         }
3079       }
3080      }
3081      else {
3082       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3083       fp = fopen(file,"w");
3084       if (!fp) {
3085         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3086         fp = fopen(file,"w");
3087         if (!fp) {
3088           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3089           fp = fopen(file,"w");
3090         }
3091       }
3092     }
3093     if (!fp) return 0;  /* we're hosed */
3094
3095     fprintf(fp,"$! 'f$verify(0)'\n");
3096     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3097     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3098     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3099     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3100     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3101     fprintf(fp,"$ perl_del    = \"delete\"\n");
3102     fprintf(fp,"$ pif         = \"if\"\n");
3103     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3104     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3105     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3106     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3107     fprintf(fp,"$!  --- build command line to get max possible length\n");
3108     fprintf(fp,"$c=perl_popen_cmd0\n");
3109     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3110     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3111     fprintf(fp,"$x=perl_popen_cmd3\n");
3112     fprintf(fp,"$c=c+x\n");
3113     fprintf(fp,"$ perl_on\n");
3114     fprintf(fp,"$ 'c'\n");
3115     fprintf(fp,"$ perl_status = $STATUS\n");
3116     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3117     fprintf(fp,"$ perl_exit 'perl_status'\n");
3118     fsync(fileno(fp));
3119
3120     fgetname(fp, file, 1);
3121     fstat(fileno(fp), (struct stat *)&s0);
3122     fclose(fp);
3123
3124     if (decc_filename_unix_only)
3125         do_tounixspec(file, file, 0);
3126     fp = fopen(file,"r","shr=get");
3127     if (!fp) return 0;
3128     fstat(fileno(fp), (struct stat *)&s1);
3129
3130     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3131     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3132         fclose(fp);
3133         return 0;
3134     }
3135
3136     return fp;
3137 }
3138
3139
3140
3141 static PerlIO *
3142 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3143 {
3144     static int handler_set_up = FALSE;
3145     unsigned long int sts, flags = CLI$M_NOWAIT;
3146     /* The use of a GLOBAL table (as was done previously) rendered
3147      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3148      * environment.  Hence we've switched to LOCAL symbol table.
3149      */
3150     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3151     int j, wait = 0, n;
3152     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3153     char in[512], out[512], err[512], mbx[512];
3154     FILE *tpipe = 0;
3155     char tfilebuf[NAM$C_MAXRSS+1];
3156     pInfo info = NULL;
3157     char cmd_sym_name[20];
3158     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3159                                       DSC$K_CLASS_S, symbol};
3160     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3161                                       DSC$K_CLASS_S, 0};
3162     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3163                                       DSC$K_CLASS_S, cmd_sym_name};
3164     struct dsc$descriptor_s *vmscmd;
3165     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3166     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3167     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3168
3169     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3170
3171     /* once-per-program initialization...
3172        note that the SETAST calls and the dual test of pipe_ef
3173        makes sure that only the FIRST thread through here does
3174        the initialization...all other threads wait until it's
3175        done.
3176
3177        Yeah, uglier than a pthread call, it's got all the stuff inline
3178        rather than in a separate routine.
3179     */
3180
3181     if (!pipe_ef) {
3182         _ckvmssts(sys$setast(0));
3183         if (!pipe_ef) {
3184             unsigned long int pidcode = JPI$_PID;
3185             $DESCRIPTOR(d_delay, RETRY_DELAY);
3186             _ckvmssts(lib$get_ef(&pipe_ef));
3187             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3188             _ckvmssts(sys$bintim(&d_delay, delaytime));
3189         }
3190         if (!handler_set_up) {
3191           _ckvmssts(sys$dclexh(&pipe_exitblock));
3192           handler_set_up = TRUE;
3193         }
3194         _ckvmssts(sys$setast(1));
3195     }
3196
3197     /* see if we can find a VMSPIPE.COM */
3198
3199     tfilebuf[0] = '@';
3200     vmspipe = find_vmspipe(aTHX);
3201     if (vmspipe) {
3202         strcpy(tfilebuf+1,vmspipe);
3203     } else {        /* uh, oh...we're in tempfile hell */
3204         tpipe = vmspipe_tempfile(aTHX);
3205         if (!tpipe) {       /* a fish popular in Boston */
3206             if (ckWARN(WARN_PIPE)) {
3207                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3208             }
3209         return Nullfp;
3210         }
3211         fgetname(tpipe,tfilebuf+1,1);
3212     }
3213     vmspipedsc.dsc$a_pointer = tfilebuf;
3214     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3215
3216     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3217     if (!(sts & 1)) {
3218       switch (sts) {
3219         case RMS$_FNF:  case RMS$_DNF:
3220           set_errno(ENOENT); break;
3221         case RMS$_DIR:
3222           set_errno(ENOTDIR); break;
3223         case RMS$_DEV:
3224           set_errno(ENODEV); break;
3225         case RMS$_PRV:
3226           set_errno(EACCES); break;
3227         case RMS$_SYN:
3228           set_errno(EINVAL); break;
3229         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3230           set_errno(E2BIG); break;
3231         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3232           _ckvmssts(sts); /* fall through */
3233         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3234           set_errno(EVMSERR);
3235       }
3236       set_vaxc_errno(sts);
3237       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3238         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3239       }
3240       *psts = sts;
3241       return Nullfp;
3242     }
3243     n = sizeof(Info);
3244     _ckvmssts(lib$get_vm(&n, &info));
3245
3246     strcpy(mode,in_mode);
3247     info->mode = *mode;
3248     info->done = FALSE;
3249     info->completion = 0;
3250     info->closing    = FALSE;
3251     info->in         = 0;
3252     info->out        = 0;
3253     info->err        = 0;
3254     info->fp         = Nullfp;
3255     info->useFILE    = 0;
3256     info->waiting    = 0;
3257     info->in_done    = TRUE;
3258     info->out_done   = TRUE;
3259     info->err_done   = TRUE;
3260     in[0] = out[0] = err[0] = '\0';
3261
3262     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3263         info->useFILE = 1;
3264         strcpy(p,p+1);
3265     }
3266     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3267         wait = 1;
3268         strcpy(p,p+1);
3269     }
3270
3271     if (*mode == 'r') {             /* piping from subroutine */
3272
3273         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3274         if (info->out) {
3275             info->out->pipe_done = &info->out_done;
3276             info->out_done = FALSE;
3277             info->out->info = info;
3278         }
3279         if (!info->useFILE) {
3280         info->fp  = PerlIO_open(mbx, mode);
3281         } else {
3282             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3283             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3284         }
3285
3286         if (!info->fp && info->out) {
3287             sys$cancel(info->out->chan_out);
3288
3289             while (!info->out_done) {
3290                 int done;
3291                 _ckvmssts(sys$setast(0));
3292                 done = info->out_done;
3293                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3294                 _ckvmssts(sys$setast(1));
3295                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3296             }
3297
3298             if (info->out->buf) {
3299                 n = info->out->bufsize * sizeof(char);
3300                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3301             }
3302             n = sizeof(Pipe);
3303             _ckvmssts(lib$free_vm(&n, &info->out));
3304             n = sizeof(Info);
3305             _ckvmssts(lib$free_vm(&n, &info));
3306             *psts = RMS$_FNF;
3307             return Nullfp;
3308         }
3309
3310         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3311         if (info->err) {
3312             info->err->pipe_done = &info->err_done;
3313             info->err_done = FALSE;
3314             info->err->info = info;
3315         }
3316
3317     } else if (*mode == 'w') {      /* piping to subroutine */
3318
3319         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3320         if (info->out) {
3321             info->out->pipe_done = &info->out_done;
3322             info->out_done = FALSE;
3323             info->out->info = info;
3324         }
3325
3326         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3327         if (info->err) {
3328             info->err->pipe_done = &info->err_done;
3329             info->err_done = FALSE;
3330             info->err->info = info;
3331         }
3332
3333         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3334         if (!info->useFILE) {
3335             info->fp  = PerlIO_open(mbx, mode);
3336         } else {
3337             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3338             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3339         }
3340
3341         if (info->in) {
3342             info->in->pipe_done = &info->in_done;
3343             info->in_done = FALSE;
3344             info->in->info = info;
3345         }
3346
3347         /* error cleanup */
3348         if (!info->fp && info->in) {
3349             info->done = TRUE;
3350             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3351                               0, 0, 0, 0, 0, 0, 0, 0));
3352
3353             while (!info->in_done) {
3354                 int done;
3355                 _ckvmssts(sys$setast(0));
3356                 done = info->in_done;
3357                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3358                 _ckvmssts(sys$setast(1));
3359                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3360             }
3361
3362             if (info->in->buf) {
3363                 n = info->in->bufsize * sizeof(char);
3364                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3365             }
3366             n = sizeof(Pipe);
3367             _ckvmssts(lib$free_vm(&n, &info->in));
3368             n = sizeof(Info);
3369             _ckvmssts(lib$free_vm(&n, &info));
3370             *psts = RMS$_FNF;
3371             return Nullfp;
3372         }
3373
3374
3375     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3376         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3377         if (info->out) {
3378             info->out->pipe_done = &info->out_done;
3379             info->out_done = FALSE;
3380             info->out->info = info;
3381         }
3382
3383         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3384         if (info->err) {
3385             info->err->pipe_done = &info->err_done;
3386             info->err_done = FALSE;
3387             info->err->info = info;
3388         }
3389     }
3390
3391     symbol[MAX_DCL_SYMBOL] = '\0';
3392
3393     strncpy(symbol, in, MAX_DCL_SYMBOL);
3394     d_symbol.dsc$w_length = strlen(symbol);
3395     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3396
3397     strncpy(symbol, err, MAX_DCL_SYMBOL);
3398     d_symbol.dsc$w_length = strlen(symbol);
3399     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3400
3401     strncpy(symbol, out, MAX_DCL_SYMBOL);
3402     d_symbol.dsc$w_length = strlen(symbol);
3403     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3404
3405     p = vmscmd->dsc$a_pointer;
3406     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3407     if (*p == '$') p++;                         /* remove leading $ */
3408     while (*p == ' ' || *p == '\t') p++;
3409
3410     for (j = 0; j < 4; j++) {
3411         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3412         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3413
3414     strncpy(symbol, p, MAX_DCL_SYMBOL);
3415     d_symbol.dsc$w_length = strlen(symbol);
3416     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3417
3418         if (strlen(p) > MAX_DCL_SYMBOL) {
3419             p += MAX_DCL_SYMBOL;
3420         } else {
3421             p += strlen(p);
3422         }
3423     }
3424     _ckvmssts(sys$setast(0));
3425     info->next=open_pipes;  /* prepend to list */
3426     open_pipes=info;
3427     _ckvmssts(sys$setast(1));
3428     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3429      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3430      * have SYS$COMMAND if we need it.
3431      */
3432     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3433                       0, &info->pid, &info->completion,
3434                       0, popen_completion_ast,info,0,0,0));
3435
3436     /* if we were using a tempfile, close it now */
3437
3438     if (tpipe) fclose(tpipe);
3439
3440     /* once the subprocess is spawned, it has copied the symbols and
3441        we can get rid of ours */
3442
3443     for (j = 0; j < 4; j++) {
3444         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3445         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3446     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3447     }
3448     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3449     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3450     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3451     vms_execfree(vmscmd);
3452
3453 #ifdef PERL_IMPLICIT_CONTEXT
3454     if (aTHX)
3455 #endif
3456     PL_forkprocess = info->pid;
3457
3458     if (wait) {
3459          int done = 0;
3460          while (!done) {
3461              _ckvmssts(sys$setast(0));
3462              done = info->done;
3463              if (!done) _ckvmssts(sys$clref(pipe_ef));
3464              _ckvmssts(sys$setast(1));
3465              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3466          }
3467         *psts = info->completion;
3468 /* Caller thinks it is open and tries to close it. */
3469 /* This causes some problems, as it changes the error status */
3470 /*        my_pclose(info->fp); */
3471     } else {
3472         *psts = SS$_NORMAL;
3473     }
3474     return info->fp;
3475 }  /* end of safe_popen */
3476
3477
3478 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3479 PerlIO *
3480 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3481 {
3482     int sts;
3483     TAINT_ENV();
3484     TAINT_PROPER("popen");
3485     PERL_FLUSHALL_FOR_CHILD;
3486     return safe_popen(aTHX_ cmd,mode,&sts);
3487 }
3488
3489 /*}}}*/
3490
3491 /*{{{  I32 my_pclose(PerlIO *fp)*/
3492 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3493 {
3494     pInfo info, last = NULL;
3495     unsigned long int retsts;
3496     int done, iss, n;
3497
3498     for (info = open_pipes; info != NULL; last = info, info = info->next)
3499         if (info->fp == fp) break;
3500
3501     if (info == NULL) {  /* no such pipe open */
3502       set_errno(ECHILD); /* quoth POSIX */
3503       set_vaxc_errno(SS$_NONEXPR);
3504       return -1;
3505     }
3506
3507     /* If we were writing to a subprocess, insure that someone reading from
3508      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3509      * produce an EOF record in the mailbox.
3510      *
3511      *  well, at least sometimes it *does*, so we have to watch out for
3512      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3513      */
3514      if (info->fp) {
3515         if (!info->useFILE)
3516             PerlIO_flush(info->fp);   /* first, flush data */
3517         else
3518             fflush((FILE *)info->fp);
3519     }
3520
3521     _ckvmssts(sys$setast(0));
3522      info->closing = TRUE;
3523      done = info->done && info->in_done && info->out_done && info->err_done;
3524      /* hanging on write to Perl's input? cancel it */
3525      if (info->mode == 'r' && info->out && !info->out_done) {
3526         if (info->out->chan_out) {
3527             _ckvmssts(sys$cancel(info->out->chan_out));
3528             if (!info->out->chan_in) {   /* EOF generation, need AST */
3529                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3530             }
3531         }
3532      }
3533      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3534          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3535                            0, 0, 0, 0, 0, 0));
3536     _ckvmssts(sys$setast(1));
3537     if (info->fp) {
3538      if (!info->useFILE)
3539         PerlIO_close(info->fp);
3540      else
3541         fclose((FILE *)info->fp);
3542     }
3543      /*
3544         we have to wait until subprocess completes, but ALSO wait until all
3545         the i/o completes...otherwise we'll be freeing the "info" structure
3546         that the i/o ASTs could still be using...
3547      */
3548
3549      while (!done) {
3550          _ckvmssts(sys$setast(0));
3551          done = info->done && info->in_done && info->out_done && info->err_done;
3552          if (!done) _ckvmssts(sys$clref(pipe_ef));
3553          _ckvmssts(sys$setast(1));
3554          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3555      }
3556      retsts = info->completion;
3557
3558     /* remove from list of open pipes */
3559     _ckvmssts(sys$setast(0));
3560     if (last) last->next = info->next;
3561     else open_pipes = info->next;
3562     _ckvmssts(sys$setast(1));
3563
3564     /* free buffers and structures */
3565
3566     if (info->in) {
3567         if (info->in->buf) {
3568             n = info->in->bufsize * sizeof(char);
3569             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3570         }
3571         n = sizeof(Pipe);
3572         _ckvmssts(lib$free_vm(&n, &info->in));
3573     }
3574     if (info->out) {
3575         if (info->out->buf) {
3576             n = info->out->bufsize * sizeof(char);
3577             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3578         }
3579         n = sizeof(Pipe);
3580         _ckvmssts(lib$free_vm(&n, &info->out));
3581     }
3582     if (info->err) {
3583         if (info->err->buf) {
3584             n = info->err->bufsize * sizeof(char);
3585             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3586         }
3587         n = sizeof(Pipe);
3588         _ckvmssts(lib$free_vm(&n, &info->err));
3589     }
3590     n = sizeof(Info);
3591     _ckvmssts(lib$free_vm(&n, &info));
3592
3593     return retsts;
3594
3595 }  /* end of my_pclose() */
3596
3597 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3598   /* Roll our own prototype because we want this regardless of whether
3599    * _VMS_WAIT is defined.
3600    */
3601   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3602 #endif
3603 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3604    created with popen(); otherwise partially emulate waitpid() unless
3605    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3606    Also check processes not considered by the CRTL waitpid().
3607  */
3608 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3609 Pid_t
3610 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3611 {
3612     pInfo info;
3613     int done;
3614     int sts;
3615     int j;
3616
3617     if (statusp) *statusp = 0;
3618
3619     for (info = open_pipes; info != NULL; info = info->next)
3620         if (info->pid == pid) break;
3621
3622     if (info != NULL) {  /* we know about this child */
3623       while (!info->done) {
3624           _ckvmssts(sys$setast(0));
3625           done = info->done;
3626           if (!done) _ckvmssts(sys$clref(pipe_ef));
3627           _ckvmssts(sys$setast(1));
3628           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3629       }
3630
3631       if (statusp) *statusp = info->completion;
3632       return pid;
3633     }
3634
3635     /* child that already terminated? */
3636
3637     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3638         if (closed_list[j].pid == pid) {
3639             if (statusp) *statusp = closed_list[j].completion;
3640             return pid;
3641         }
3642     }
3643
3644     /* fall through if this child is not one of our own pipe children */
3645
3646 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3647
3648       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3649        * in 7.2 did we get a version that fills in the VMS completion
3650        * status as Perl has always tried to do.
3651        */
3652
3653       sts = __vms_waitpid( pid, statusp, flags );
3654
3655       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3656          return sts;
3657
3658       /* If the real waitpid tells us the child does not exist, we
3659        * fall through here to implement waiting for a child that
3660        * was created by some means other than exec() (say, spawned
3661        * from DCL) or to wait for a process that is not a subprocess
3662        * of the current process.
3663        */
3664
3665 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3666
3667     {
3668       $DESCRIPTOR(intdsc,"0 00:00:01");
3669       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3670       unsigned long int pidcode = JPI$_PID, mypid;
3671       unsigned long int interval[2];
3672       unsigned int jpi_iosb[2];
3673       struct itmlst_3 jpilist[2] = {
3674           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3675           {                      0,         0,                 0, 0}
3676       };
3677
3678       if (pid <= 0) {
3679         /* Sorry folks, we don't presently implement rooting around for
3680            the first child we can find, and we definitely don't want to
3681            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3682          */
3683         set_errno(ENOTSUP);
3684         return -1;
3685       }
3686
3687       /* Get the owner of the child so I can warn if it's not mine. If the
3688        * process doesn't exist or I don't have the privs to look at it,
3689        * I can go home early.
3690        */
3691       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3692       if (sts & 1) sts = jpi_iosb[0];
3693       if (!(sts & 1)) {
3694         switch (sts) {
3695             case SS$_NONEXPR:
3696                 set_errno(ECHILD);
3697                 break;
3698             case SS$_NOPRIV:
3699                 set_errno(EACCES);
3700                 break;
3701             default:
3702                 _ckvmssts(sts);
3703         }
3704         set_vaxc_errno(sts);
3705         return -1;
3706       }
3707
3708       if (ckWARN(WARN_EXEC)) {
3709         /* remind folks they are asking for non-standard waitpid behavior */
3710         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3711         if (ownerpid != mypid)
3712           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3713                       "waitpid: process %x is not a child of process %x",
3714                       pid,mypid);
3715       }
3716
3717       /* simply check on it once a second until it's not there anymore. */
3718
3719       _ckvmssts(sys$bintim(&intdsc,interval));
3720       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3721             _ckvmssts(sys$schdwk(0,0,interval,0));
3722             _ckvmssts(sys$hiber());
3723       }
3724       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3725
3726       _ckvmssts(sts);
3727       return pid;
3728     }
3729 }  /* end of waitpid() */
3730 /*}}}*/
3731 /*}}}*/
3732 /*}}}*/
3733
3734 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3735 char *
3736 my_gconvert(double val, int ndig, int trail, char *buf)
3737 {
3738   static char __gcvtbuf[DBL_DIG+1];
3739   char *loc;
3740
3741   loc = buf ? buf : __gcvtbuf;
3742
3743 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3744   if (val < 1) {
3745     sprintf(loc,"%.*g",ndig,val);
3746     return loc;
3747   }
3748 #endif
3749
3750   if (val) {
3751     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3752     return gcvt(val,ndig,loc);
3753   }
3754   else {
3755     loc[0] = '0'; loc[1] = '\0';
3756     return loc;
3757   }
3758
3759 }
3760 /*}}}*/
3761
3762 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3763 static int rms_free_search_context(struct FAB * fab)
3764 {
3765 struct NAM * nam;
3766
3767     nam = fab->fab$l_nam;
3768     nam->nam$b_nop |= NAM$M_SYNCHK;
3769     nam->nam$l_rlf = NULL;
3770     fab->fab$b_dns = 0;
3771     return sys$parse(fab, NULL, NULL);
3772 }
3773
3774 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3775 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3776 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3777 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3778 #define rms_nam_esll(nam) nam.nam$b_esl
3779 #define rms_nam_esl(nam) nam.nam$b_esl
3780 #define rms_nam_name(nam) nam.nam$l_name
3781 #define rms_nam_namel(nam) nam.nam$l_name
3782 #define rms_nam_type(nam) nam.nam$l_type
3783 #define rms_nam_typel(nam) nam.nam$l_type
3784 #define rms_nam_ver(nam) nam.nam$l_ver
3785 #define rms_nam_verl(nam) nam.nam$l_ver
3786 #define rms_nam_rsll(nam) nam.nam$b_rsl
3787 #define rms_nam_rsl(nam) nam.nam$b_rsl
3788 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3789 #define rms_set_fna(fab, nam, name, size) \
3790         fab.fab$b_fns = size; fab.fab$l_fna = name;
3791 #define rms_get_fna(fab, nam) fab.fab$l_fna
3792 #define rms_set_dna(fab, nam, name, size) \
3793         fab.fab$b_dns = size; fab.fab$l_dna = name;
3794 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3795 #define rms_set_esa(fab, nam, name, size) \
3796         nam.nam$b_ess = size; nam.nam$l_esa = name;
3797 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3798         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3799 #define rms_set_rsa(nam, name, size) \
3800         nam.nam$l_rsa = name; nam.nam$b_rss = size;
3801 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3802         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3803
3804 #else
3805 static int rms_free_search_context(struct FAB * fab)
3806 {
3807 struct NAML * nam;
3808
3809     nam = fab->fab$l_naml;
3810     nam->naml$b_nop |= NAM$M_SYNCHK;
3811     nam->naml$l_rlf = NULL;
3812     nam->naml$l_long_defname_size = 0;
3813     fab->fab$b_dns = 0;
3814     return sys$parse(fab, NULL, NULL);
3815 }
3816
3817 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3818 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3819 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3820 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3821 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3822 #define rms_nam_esl(nam) nam.naml$b_esl
3823 #define rms_nam_name(nam) nam.naml$l_name
3824 #define rms_nam_namel(nam) nam.naml$l_long_name
3825 #define rms_nam_type(nam) nam.naml$l_type
3826 #define rms_nam_typel(nam) nam.naml$l_long_type
3827 #define rms_nam_ver(nam) nam.naml$l_ver
3828 #define rms_nam_verl(nam) nam.naml$l_long_ver
3829 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3830 #define rms_nam_rsl(nam) nam.naml$b_rsl
3831 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3832 #define rms_set_fna(fab, nam, name, size) \
3833         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3834         nam.naml$l_long_filename_size = size; \
3835         nam.naml$l_long_filename = name
3836 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3837 #define rms_set_dna(fab, nam, name, size) \
3838         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3839         nam.naml$l_long_defname_size = size; \
3840         nam.naml$l_long_defname = name
3841 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3842 #define rms_set_esa(fab, nam, name, size) \
3843         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3844         nam.naml$l_long_expand_alloc = size; \
3845         nam.naml$l_long_expand = name
3846 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3847         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3848         nam.naml$l_long_expand = l_name; \
3849         nam.naml$l_long_expand_alloc = l_size;
3850 #define rms_set_rsa(nam, name, size) \
3851         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3852         nam.naml$l_long_result = name; \
3853         nam.naml$l_long_result_alloc = size;
3854 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3855         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3856         nam.naml$l_long_result = l_name; \
3857         nam.naml$l_long_result_alloc = l_size;
3858
3859 #endif
3860
3861
3862 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3863 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3864  * to expand file specification.  Allows for a single default file
3865  * specification and a simple mask of options.  If outbuf is non-NULL,
3866  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3867  * the resultant file specification is placed.  If outbuf is NULL, the
3868  * resultant file specification is placed into a static buffer.
3869  * The third argument, if non-NULL, is taken to be a default file
3870  * specification string.  The fourth argument is unused at present.
3871  * rmesexpand() returns the address of the resultant string if
3872  * successful, and NULL on error.
3873  *
3874  * New functionality for previously unused opts value:
3875  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3876  */
3877 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3878
3879 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3880 /* ODS-2 only version */
3881 static char *
3882 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3883 {
3884   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3885   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3886   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3887   struct FAB myfab = cc$rms_fab;
3888   struct NAM mynam = cc$rms_nam;
3889   STRLEN speclen;
3890   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3891   int sts;
3892
3893   if (!filespec || !*filespec) {
3894     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3895     return NULL;
3896   }
3897   if (!outbuf) {
3898     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3899     else    outbuf = __rmsexpand_retbuf;
3900   }
3901   isunix = is_unix_filespec(filespec);
3902   if (isunix) {
3903     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3904         if (out)
3905            Safefree(out);
3906         return NULL;
3907     }
3908     filespec = vmsfspec;
3909   }
3910
3911   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3912   myfab.fab$b_fns = strlen(filespec);
3913   myfab.fab$l_nam = &mynam;
3914
3915   if (defspec && *defspec) {
3916     if (strchr(defspec,'/') != NULL) {
3917       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3918         if (out)
3919            Safefree(out);
3920         return NULL;
3921       }
3922       defspec = tmpfspec;
3923     }
3924     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3925     myfab.fab$b_dns = strlen(defspec);
3926   }
3927
3928   mynam.nam$l_esa = esa;
3929   mynam.nam$b_ess = sizeof esa;
3930   mynam.nam$l_rsa = outbuf;
3931   mynam.nam$b_rss = NAM$C_MAXRSS;
3932
3933 #ifdef NAM$M_NO_SHORT_UPCASE
3934   if (decc_efs_case_preserve)
3935     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3936 #endif
3937
3938   retsts = sys$parse(&myfab,0,0);
3939   if (!(retsts & 1)) {
3940     mynam.nam$b_nop |= NAM$M_SYNCHK;
3941     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3942       retsts = sys$parse(&myfab,0,0);
3943       if (retsts & 1) goto expanded;
3944     }
3945     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3946     sts = sys$parse(&myfab,0,0);  /* Free search context */
3947     if (out) Safefree(out);
3948     set_vaxc_errno(retsts);
3949     if      (retsts == RMS$_PRV) set_errno(EACCES);
3950     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3951     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3952     else                         set_errno(EVMSERR);
3953     return NULL;
3954   }
3955   retsts = sys$search(&myfab,0,0);
3956   if (!(retsts & 1) && retsts != RMS$_FNF) {
3957     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3958     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3959     if (out) Safefree(out);
3960     set_vaxc_errno(retsts);
3961     if      (retsts == RMS$_PRV) set_errno(EACCES);
3962     else                         set_errno(EVMSERR);
3963     return NULL;
3964   }
3965
3966   /* If the input filespec contained any lowercase characters,
3967    * downcase the result for compatibility with Unix-minded code. */
3968   expanded:
3969   if (!decc_efs_case_preserve) {
3970     for (out = myfab.fab$l_fna; *out; out++)
3971       if (islower(*out)) { haslower = 1; break; }
3972   }
3973   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3974   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3975   /* Trim off null fields added by $PARSE
3976    * If type > 1 char, must have been specified in original or default spec
3977    * (not true for version; $SEARCH may have added version of existing file).
3978    */
3979   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3980   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3981              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3982   if (trimver || trimtype) {
3983     if (defspec && *defspec) {
3984       char defesa[NAM$C_MAXRSS];
3985       struct FAB deffab = cc$rms_fab;
3986       struct NAM defnam = cc$rms_nam;
3987
3988       deffab.fab$l_nam = &defnam;
3989       /* cast below ok for read only pointer */
3990       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3991       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3992       defnam.nam$b_nop = NAM$M_SYNCHK;
3993 #ifdef NAM$M_NO_SHORT_UPCASE
3994       if (decc_efs_case_preserve)
3995         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3996 #endif
3997       if (sys$parse(&deffab,0,0) & 1) {
3998         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3999         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4000       }
4001     }
4002     if (trimver) {
4003       if (*mynam.nam$l_ver != '\"')
4004         speclen = mynam.nam$l_ver - out;
4005     }
4006     if (trimtype) {
4007       /* If we didn't already trim version, copy down */
4008       if (speclen > mynam.nam$l_ver - out)
4009         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4010                speclen - (mynam.nam$l_ver - out));
4011       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4012     }
4013   }
4014   /* If we just had a directory spec on input, $PARSE "helpfully"
4015    * adds an empty name and type for us */
4016   if (mynam.nam$l_name == mynam.nam$l_type &&
4017       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4018       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4019     speclen = mynam.nam$l_name - out;
4020
4021   /* Posix format specifications must have matching quotes */
4022   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4023     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4024       out[speclen] = '\"';
4025       speclen++;
4026     }
4027   }
4028
4029   out[speclen] = '\0';
4030   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4031
4032   /* Have we been working with an expanded, but not resultant, spec? */
4033   /* Also, convert back to Unix syntax if necessary. */
4034   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4035     isunix = 0;
4036
4037   if (!mynam.nam$b_rsl) {
4038     if (isunix) {
4039       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4040     }
4041     else strcpy(outbuf,esa);
4042   }
4043   else if (isunix) {
4044     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4045     strcpy(outbuf,tmpfspec);
4046   }
4047   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4048   mynam.nam$l_rsa = NULL;
4049   mynam.nam$b_rss = 0;
4050   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4051   return outbuf;
4052 }
4053 #else
4054 /* ODS-5 supporting routine */
4055 static char *
4056 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4057 {
4058   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4059   char * vmsfspec, *tmpfspec;
4060   char * esa, *cp, *out = NULL;
4061   char * esal;
4062   char * outbufl;
4063   struct FAB myfab = cc$rms_fab;
4064   rms_setup_nam(mynam);
4065   STRLEN speclen;
4066   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4067   int sts;
4068
4069   if (!filespec || !*filespec) {
4070     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4071     return NULL;
4072   }
4073   if (!outbuf) {
4074     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4075     else    outbuf = __rmsexpand_retbuf;
4076   }
4077
4078   vmsfspec = NULL;
4079   tmpfspec = NULL;
4080   outbufl = NULL;
4081   isunix = is_unix_filespec(filespec);
4082   if (isunix) {
4083     Newx(vmsfspec, VMS_MAXRSS, char);
4084     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4085         Safefree(vmsfspec);
4086         if (out)
4087            Safefree(out);
4088         return NULL;
4089     }
4090     filespec = vmsfspec;
4091
4092      /* Unless we are forcing to VMS format, a UNIX input means
4093       * UNIX output, and that requires long names to be used
4094       */
4095     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4096         opts |= PERL_RMSEXPAND_M_LONG;
4097     else {
4098         isunix = 0;
4099     }
4100   }
4101
4102   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4103   rms_bind_fab_nam(myfab, mynam);
4104
4105   if (defspec && *defspec) {
4106     int t_isunix;
4107     t_isunix = is_unix_filespec(defspec);
4108     if (t_isunix) {
4109       Newx(tmpfspec, VMS_MAXRSS, char);
4110       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4111         Safefree(tmpfspec);
4112         if (vmsfspec != NULL)
4113             Safefree(vmsfspec);
4114         if (out)
4115            Safefree(out);
4116         return NULL;
4117       }
4118       defspec = tmpfspec;
4119     }
4120     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4121   }
4122
4123   Newx(esa, NAM$C_MAXRSS + 1, char);
4124 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4125   Newx(esal, NAML$C_MAXRSS + 1, char);
4126 #endif
4127   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4128
4129   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4130     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4131   }
4132   else {
4133 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4134     Newx(outbufl, VMS_MAXRSS, char);
4135     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4136 #else
4137     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4138 #endif
4139   }
4140
4141 #ifdef NAM$M_NO_SHORT_UPCASE
4142   if (decc_efs_case_preserve)
4143     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4144 #endif
4145
4146   /* First attempt to parse as an existing file */
4147   retsts = sys$parse(&myfab,0,0);
4148   if (!(retsts & STS$K_SUCCESS)) {
4149
4150     /* Could not find the file, try as syntax only if error is not fatal */
4151     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4152     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4153       retsts = sys$parse(&myfab,0,0);
4154       if (retsts & STS$K_SUCCESS) goto expanded;
4155     }
4156
4157      /* Still could not parse the file specification */
4158     /*----------------------------------------------*/
4159     sts = rms_free_search_context(&myfab); /* Free search context */
4160     if (out) Safefree(out);
4161     if (tmpfspec != NULL)
4162         Safefree(tmpfspec);
4163     if (vmsfspec != NULL)
4164         Safefree(vmsfspec);
4165     Safefree(esa);
4166     Safefree(esal);
4167     set_vaxc_errno(retsts);
4168     if      (retsts == RMS$_PRV) set_errno(EACCES);
4169     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4170     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4171     else                         set_errno(EVMSERR);
4172     return NULL;
4173   }
4174   retsts = sys$search(&myfab,0,0);
4175   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4176     sts = rms_free_search_context(&myfab); /* Free search context */
4177     if (out) Safefree(out);
4178     if (tmpfspec != NULL)
4179         Safefree(tmpfspec);
4180     if (vmsfspec != NULL)
4181         Safefree(vmsfspec);
4182     Safefree(esa);
4183     Safefree(esal);
4184     set_vaxc_errno(retsts);
4185     if      (retsts == RMS$_PRV) set_errno(EACCES);
4186     else                         set_errno(EVMSERR);
4187     return NULL;
4188   }
4189
4190   /* If the input filespec contained any lowercase characters,
4191    * downcase the result for compatibility with Unix-minded code. */
4192   expanded:
4193   if (!decc_efs_case_preserve) {
4194     for (out = rms_get_fna(myfab, mynam); *out; out++)
4195       if (islower(*out)) { haslower = 1; break; }
4196   }
4197
4198    /* Is a long or a short name expected */
4199   /*------------------------------------*/
4200   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4201     if (rms_nam_rsll(mynam)) {
4202         out = outbuf;
4203         speclen = rms_nam_rsll(mynam);
4204     }
4205     else {
4206         out = esal; /* Not esa */
4207         speclen = rms_nam_esll(mynam);
4208     }
4209   }
4210   else {
4211     if (rms_nam_rsl(mynam)) {
4212         out = outbuf;
4213         speclen = rms_nam_rsl(mynam);
4214     }
4215     else {
4216         out = esa; /* Not esal */
4217         speclen = rms_nam_esl(mynam);
4218     }
4219   }
4220   /* Trim off null fields added by $PARSE
4221    * If type > 1 char, must have been specified in original or default spec
4222    * (not true for version; $SEARCH may have added version of existing file).
4223    */
4224   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4225   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4226     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4227              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4228   }
4229   else {
4230     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4231              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4232   }
4233   if (trimver || trimtype) {
4234     if (defspec && *defspec) {
4235       char *defesal = NULL;
4236       Newx(defesal, NAML$C_MAXRSS + 1, char);
4237       if (defesal != NULL) {
4238         struct FAB deffab = cc$rms_fab;
4239         rms_setup_nam(defnam);
4240
4241         rms_bind_fab_nam(deffab, defnam);
4242
4243         /* Cast ok */
4244         rms_set_fna
4245             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4246
4247         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4248
4249         rms_set_nam_nop(defnam, 0);
4250         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4251 #ifdef NAM$M_NO_SHORT_UPCASE
4252         if (decc_efs_case_preserve)
4253           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4254 #endif
4255         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4256           if (trimver) {
4257              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4258           }
4259           if (trimtype) {
4260             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4261           }
4262         }
4263         Safefree(defesal);
4264       }
4265     }
4266     if (trimver) {
4267       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4268         if (*(rms_nam_verl(mynam)) != '\"')
4269           speclen = rms_nam_verl(mynam) - out;
4270       }
4271       else {
4272         if (*(rms_nam_ver(mynam)) != '\"')
4273           speclen = rms_nam_ver(mynam) - out;
4274       }
4275     }
4276     if (trimtype) {
4277       /* If we didn't already trim version, copy down */
4278       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4279         if (speclen > rms_nam_verl(mynam) - out)
4280           memmove
4281            (rms_nam_typel(mynam),
4282             rms_nam_verl(mynam),
4283             speclen - (rms_nam_verl(mynam) - out));
4284           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4285       }
4286       else {
4287         if (speclen > rms_nam_ver(mynam) - out)
4288           memmove
4289            (rms_nam_type(mynam),
4290             rms_nam_ver(mynam),
4291             speclen - (rms_nam_ver(mynam) - out));
4292           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4293       }
4294     }
4295   }
4296
4297    /* Done with these copies of the input files */
4298   /*-------------------------------------------*/
4299   if (vmsfspec != NULL)
4300         Safefree(vmsfspec);
4301   if (tmpfspec != NULL)
4302         Safefree(tmpfspec);
4303
4304   /* If we just had a directory spec on input, $PARSE "helpfully"
4305    * adds an empty name and type for us */
4306   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4307     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4308         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4309         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4310       speclen = rms_nam_namel(mynam) - out;
4311   }
4312   else {
4313     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4314         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4315         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4316       speclen = rms_nam_name(mynam) - out;
4317   }
4318
4319   /* Posix format specifications must have matching quotes */
4320   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4321     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4322       out[speclen] = '\"';
4323       speclen++;
4324     }
4325   }
4326   out[speclen] = '\0';
4327   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4328
4329   /* Have we been working with an expanded, but not resultant, spec? */
4330   /* Also, convert back to Unix syntax if necessary. */
4331
4332   if (!rms_nam_rsll(mynam)) {
4333     if (isunix) {
4334       if (do_tounixspec(esa,outbuf,0) == NULL) {
4335         Safefree(esal);
4336         Safefree(esa);
4337         return NULL;
4338       }
4339     }
4340     else strcpy(outbuf,esa);
4341   }
4342   else if (isunix) {
4343     Newx(tmpfspec, VMS_MAXRSS, char);
4344     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4345         Safefree(esa);
4346         Safefree(esal);
4347         Safefree(tmpfspec);
4348         return NULL;
4349     }
4350     strcpy(outbuf,tmpfspec);
4351     Safefree(tmpfspec);
4352   }
4353
4354   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4355   sts = rms_free_search_context(&myfab); /* Free search context */
4356   Safefree(esa);
4357   Safefree(esal);
4358   return outbuf;
4359 }
4360 #endif
4361 /*}}}*/
4362 /* External entry points */
4363 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4364 { return do_rmsexpand(spec,buf,0,def,opt); }
4365 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4366 { return do_rmsexpand(spec,buf,1,def,opt); }
4367
4368
4369 /*
4370 ** The following routines are provided to make life easier when
4371 ** converting among VMS-style and Unix-style directory specifications.
4372 ** All will take input specifications in either VMS or Unix syntax. On
4373 ** failure, all return NULL.  If successful, the routines listed below
4374 ** return a pointer to a buffer containing the appropriately
4375 ** reformatted spec (and, therefore, subsequent calls to that routine
4376 ** will clobber the result), while the routines of the same names with
4377 ** a _ts suffix appended will return a pointer to a mallocd string
4378 ** containing the appropriately reformatted spec.
4379 ** In all cases, only explicit syntax is altered; no check is made that
4380 ** the resulting string is valid or that the directory in question
4381 ** actually exists.
4382 **
4383 **   fileify_dirspec() - convert a directory spec into the name of the
4384 **     directory file (i.e. what you can stat() to see if it's a dir).
4385 **     The style (VMS or Unix) of the result is the same as the style
4386 **     of the parameter passed in.
4387 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4388 **     what you prepend to a filename to indicate what directory it's in).
4389 **     The style (VMS or Unix) of the result is the same as the style
4390 **     of the parameter passed in.
4391 **   tounixpath() - convert a directory spec into a Unix-style path.
4392 **   tovmspath() - convert a directory spec into a VMS-style path.
4393 **   tounixspec() - convert any file spec into a Unix-style file spec.
4394 **   tovmsspec() - convert any file spec into a VMS-style spec.
4395 **
4396 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4397 ** Permission is given to distribute this code as part of the Perl
4398 ** standard distribution under the terms of the GNU General Public
4399 ** License or the Perl Artistic License.  Copies of each may be
4400 ** found in the Perl standard distribution.
4401  */
4402
4403 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4404 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4405 {
4406     static char __fileify_retbuf[VMS_MAXRSS];
4407     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4408     char *retspec, *cp1, *cp2, *lastdir;
4409     char *trndir, *vmsdir;
4410     unsigned short int trnlnm_iter_count;
4411     int sts;
4412
4413     if (!dir || !*dir) {
4414       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4415     }
4416     dirlen = strlen(dir);
4417     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4418     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4419       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4420         dir = "/sys$disk";
4421         dirlen = 9;
4422       }
4423       else
4424         dirlen = 1;
4425     }
4426     if (dirlen > (VMS_MAXRSS - 1)) {
4427       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4428       return NULL;
4429     }
4430     Newx(trndir, VMS_MAXRSS + 1, char);
4431     if (!strpbrk(dir+1,"/]>:")  &&
4432         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4433       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4434       trnlnm_iter_count = 0;
4435       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4436         trnlnm_iter_count++;
4437         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4438       }
4439       dirlen = strlen(trndir);
4440     }
4441     else {
4442       strncpy(trndir,dir,dirlen);
4443       trndir[dirlen] = '\0';
4444     }
4445
4446     /* At this point we are done with *dir and use *trndir which is a
4447      * copy that can be modified.  *dir must not be modified.
4448      */
4449
4450     /* If we were handed a rooted logical name or spec, treat it like a
4451      * simple directory, so that
4452      *    $ Define myroot dev:[dir.]
4453      *    ... do_fileify_dirspec("myroot",buf,1) ...
4454      * does something useful.
4455      */
4456     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4457       trndir[--dirlen] = '\0';
4458       trndir[dirlen-1] = ']';
4459     }
4460     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4461       trndir[--dirlen] = '\0';
4462       trndir[dirlen-1] = '>';
4463     }
4464
4465     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4466       /* If we've got an explicit filename, we can just shuffle the string. */
4467       if (*(cp1+1)) hasfilename = 1;
4468       /* Similarly, we can just back up a level if we've got multiple levels
4469          of explicit directories in a VMS spec which ends with directories. */
4470       else {
4471         for (cp2 = cp1; cp2 > trndir; cp2--) {
4472           if (*cp2 == '.') {
4473             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4474               *cp2 = *cp1; *cp1 = '\0';
4475               hasfilename = 1;
4476               break;
4477             }
4478           }
4479           if (*cp2 == '[' || *cp2 == '<') break;
4480         }
4481       }
4482     }
4483
4484     Newx(vmsdir, VMS_MAXRSS + 1, char);
4485     cp1 = strpbrk(trndir,"]:>");
4486     if (hasfilename || !cp1) { /* Unix-style path or filename */
4487       if (trndir[0] == '.') {
4488         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4489           Safefree(trndir);
4490           Safefree(vmsdir);
4491           return do_fileify_dirspec("[]",buf,ts);
4492         }
4493         else if (trndir[1] == '.' &&
4494                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4495           Safefree(trndir);
4496           Safefree(vmsdir);
4497           return do_fileify_dirspec("[-]",buf,ts);
4498         }
4499       }
4500       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4501         dirlen -= 1;                 /* to last element */
4502         lastdir = strrchr(trndir,'/');
4503       }
4504       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4505         /* If we have "/." or "/..", VMSify it and let the VMS code
4506          * below expand it, rather than repeating the code to handle
4507          * relative components of a filespec here */
4508         do {
4509           if (*(cp1+2) == '.') cp1++;
4510           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4511             char * ret_chr;
4512             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4513                 Safefree(trndir);
4514                 Safefree(vmsdir);
4515                 return NULL;
4516             }
4517             if (strchr(vmsdir,'/') != NULL) {
4518               /* If do_tovmsspec() returned it, it must have VMS syntax
4519                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4520                * the time to check this here only so we avoid a recursion
4521                * loop; otherwise, gigo.
4522                */
4523               Safefree(trndir);
4524               Safefree(vmsdir);
4525               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4526               return NULL;
4527             }
4528             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4529                 Safefree(trndir);
4530                 Safefree(vmsdir);
4531                 return NULL;
4532             }
4533             ret_chr = do_tounixspec(trndir,buf,ts);
4534             Safefree(trndir);
4535             Safefree(vmsdir);
4536             return ret_chr;
4537           }
4538           cp1++;
4539         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4540         lastdir = strrchr(trndir,'/');
4541       }
4542       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4543         char * ret_chr;
4544         /* Ditto for specs that end in an MFD -- let the VMS code
4545          * figure out whether it's a real device or a rooted logical. */
4546
4547         /* This should not happen any more.  Allowing the fake /000000
4548          * in a UNIX pathname causes all sorts of problems when trying
4549          * to run in UNIX emulation.  So the VMS to UNIX conversions
4550          * now remove the fake /000000 directories.
4551          */
4552
4553         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4554         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4555             Safefree(trndir);
4556             Safefree(vmsdir);
4557             return NULL;
4558         }
4559         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4560             Safefree(trndir);
4561             Safefree(vmsdir);
4562             return NULL;
4563         }
4564         ret_chr = do_tounixspec(trndir,buf,ts);
4565         Safefree(trndir);
4566         Safefree(vmsdir);
4567         return ret_chr;
4568       }
4569       else {
4570
4571         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4572              !(lastdir = cp1 = strrchr(trndir,']')) &&
4573              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4574         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4575           int ver; char *cp3;
4576
4577           /* For EFS or ODS-5 look for the last dot */
4578           if (decc_efs_charset) {
4579               cp2 = strrchr(cp1,'.');
4580           }
4581           if (vms_process_case_tolerant) {
4582               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4583                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4584                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4585                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4586                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4587                             (ver || *cp3)))))) {
4588                   Safefree(trndir);
4589                   Safefree(vmsdir);
4590                   set_errno(ENOTDIR);
4591                   set_vaxc_errno(RMS$_DIR);
4592                   return NULL;
4593               }
4594           }
4595           else {
4596               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4597                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4598                   !*(cp2+3) || *(cp2+3) != 'R' ||
4599                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4600                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4601                             (ver || *cp3)))))) {
4602                  Safefree(trndir);
4603                  Safefree(vmsdir);
4604                  set_errno(ENOTDIR);
4605                  set_vaxc_errno(RMS$_DIR);
4606                  return NULL;
4607               }
4608           }
4609           dirlen = cp2 - trndir;
4610         }
4611       }
4612
4613       retlen = dirlen + 6;
4614       if (buf) retspec = buf;
4615       else if (ts) Newx(retspec,retlen+1,char);
4616       else retspec = __fileify_retbuf;
4617       memcpy(retspec,trndir,dirlen);
4618       retspec[dirlen] = '\0';
4619
4620       /* We've picked up everything up to the directory file name.
4621          Now just add the type and version, and we're set. */
4622       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4623         strcat(retspec,".dir;1");
4624       else
4625         strcat(retspec,".DIR;1");
4626       Safefree(trndir);
4627       Safefree(vmsdir);
4628       return retspec;
4629     }
4630     else {  /* VMS-style directory spec */
4631
4632       char *esa, term, *cp;
4633       unsigned long int sts, cmplen, haslower = 0;
4634       unsigned int nam_fnb;
4635       char * nam_type;
4636       struct FAB dirfab = cc$rms_fab;
4637       rms_setup_nam(savnam);
4638       rms_setup_nam(dirnam);
4639
4640       Newx(esa, VMS_MAXRSS + 1, char);
4641       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4642       rms_bind_fab_nam(dirfab, dirnam);
4643       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4644       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4645 #ifdef NAM$M_NO_SHORT_UPCASE
4646       if (decc_efs_case_preserve)
4647         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4648 #endif
4649
4650       for (cp = trndir; *cp; cp++)
4651         if (islower(*cp)) { haslower = 1; break; }
4652       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4653         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4654           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4655           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4656         }
4657         if (!sts) {
4658           Safefree(esa);
4659           Safefree(trndir);
4660           Safefree(vmsdir);
4661           set_errno(EVMSERR);
4662           set_vaxc_errno(dirfab.fab$l_sts);
4663           return NULL;
4664         }
4665       }
4666       else {
4667         savnam = dirnam;
4668         /* Does the file really exist? */
4669         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4670           /* Yes; fake the fnb bits so we'll check type below */
4671         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4672         }
4673         else { /* No; just work with potential name */
4674           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4675           else {
4676             Safefree(esa);
4677             Safefree(trndir);
4678             Safefree(vmsdir);
4679             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4680             sts = rms_free_search_context(&dirfab);
4681             return NULL;
4682           }
4683         }
4684       }
4685       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4686         cp1 = strchr(esa,']');
4687         if (!cp1) cp1 = strchr(esa,'>');
4688         if (cp1) {  /* Should always be true */
4689           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4690           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4691         }
4692       }
4693       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4694         /* Yep; check version while we're at it, if it's there. */
4695         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4696         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4697           /* Something other than .DIR[;1].  Bzzt. */
4698           sts = rms_free_search_context(&dirfab);
4699           Safefree(esa);
4700           Safefree(trndir);
4701           Safefree(vmsdir);
4702           set_errno(ENOTDIR);
4703           set_vaxc_errno(RMS$_DIR);
4704           return NULL;
4705         }
4706       }
4707       esa[rms_nam_esll(dirnam)] = '\0';
4708       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4709         /* They provided at least the name; we added the type, if necessary, */
4710         if (buf) retspec = buf;                            /* in sys$parse() */
4711         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4712         else retspec = __fileify_retbuf;
4713         strcpy(retspec,esa);
4714         sts = rms_free_search_context(&dirfab);
4715         Safefree(trndir);
4716         Safefree(esa);
4717         Safefree(vmsdir);
4718         return retspec;
4719       }
4720       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4721         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4722         *cp1 = '\0';
4723         rms_nam_esll(dirnam) -= 9;
4724       }
4725       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4726       if (cp1 == NULL) { /* should never happen */
4727         sts = rms_free_search_context(&dirfab);
4728         Safefree(trndir);
4729         Safefree(esa);
4730         Safefree(vmsdir);
4731         return NULL;
4732       }
4733       term = *cp1;
4734       *cp1 = '\0';
4735       retlen = strlen(esa);
4736       cp1 = strrchr(esa,'.');
4737       /* ODS-5 directory specifications can have extra "." in them. */
4738       while (cp1 != NULL) {
4739         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4740           break;
4741         else {
4742            cp1--;
4743            while ((cp1 > esa) && (*cp1 != '.'))
4744              cp1--;
4745         }
4746         if (cp1 == esa)
4747           cp1 = NULL;
4748       }
4749
4750       if ((cp1) != NULL) {
4751         /* There's more than one directory in the path.  Just roll back. */
4752         *cp1 = term;
4753         if (buf) retspec = buf;
4754         else if (ts) Newx(retspec,retlen+7,char);
4755         else retspec = __fileify_retbuf;
4756         strcpy(retspec,esa);
4757       }
4758       else {
4759         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4760           /* Go back and expand rooted logical name */
4761           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4762 #ifdef NAM$M_NO_SHORT_UPCASE
4763           if (decc_efs_case_preserve)
4764             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4765 #endif
4766           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4767             sts = rms_free_search_context(&dirfab);
4768             Safefree(esa);
4769             Safefree(trndir);
4770             Safefree(vmsdir);
4771             set_errno(EVMSERR);
4772             set_vaxc_errno(dirfab.fab$l_sts);
4773             return NULL;
4774           }
4775           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4776           if (buf) retspec = buf;
4777           else if (ts) Newx(retspec,retlen+16,char);
4778           else retspec = __fileify_retbuf;
4779           cp1 = strstr(esa,"][");
4780           if (!cp1) cp1 = strstr(esa,"]<");
4781           dirlen = cp1 - esa;
4782           memcpy(retspec,esa,dirlen);
4783           if (!strncmp(cp1+2,"000000]",7)) {
4784             retspec[dirlen-1] = '\0';
4785             /* Not full ODS-5, just extra dots in directories for now */
4786             cp1 = retspec + dirlen - 1;
4787             while (cp1 > retspec)
4788             {
4789               if (*cp1 == '[')
4790                 break;
4791               if (*cp1 == '.') {
4792                 if (*(cp1-1) != '^')
4793                   break;
4794               }
4795               cp1--;
4796             }
4797             if (*cp1 == '.') *cp1 = ']';
4798             else {
4799               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4800               memmove(cp1+1,"000000]",7);
4801             }
4802           }
4803           else {
4804             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4805             retspec[retlen] = '\0';
4806             /* Convert last '.' to ']' */
4807             cp1 = retspec+retlen-1;
4808             while (*cp != '[') {
4809               cp1--;
4810               if (*cp1 == '.') {
4811                 /* Do not trip on extra dots in ODS-5 directories */
4812                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4813                 break;
4814               }
4815             }
4816             if (*cp1 == '.') *cp1 = ']';
4817             else {
4818               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4819               memmove(cp1+1,"000000]",7);
4820             }
4821           }
4822         }
4823         else {  /* This is a top-level dir.  Add the MFD to the path. */
4824           if (buf) retspec = buf;
4825           else if (ts) Newx(retspec,retlen+16,char);
4826           else retspec = __fileify_retbuf;
4827           cp1 = esa;
4828           cp2 = retspec;
4829           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
4830           strcpy(cp2,":[000000]");
4831           cp1 += 2;
4832           strcpy(cp2+9,cp1);
4833         }
4834       }
4835       sts = rms_free_search_context(&dirfab);
4836       /* We've set up the string up through the filename.  Add the
4837          type and version, and we're done. */
4838       strcat(retspec,".DIR;1");
4839
4840       /* $PARSE may have upcased filespec, so convert output to lower
4841        * case if input contained any lowercase characters. */
4842       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4843       Safefree(trndir);
4844       Safefree(esa);
4845       Safefree(vmsdir);
4846       return retspec;
4847     }
4848 }  /* end of do_fileify_dirspec() */
4849 /*}}}*/
4850 /* External entry points */
4851 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4852 { return do_fileify_dirspec(dir,buf,0); }
4853 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4854 { return do_fileify_dirspec(dir,buf,1); }
4855
4856 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4857 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4858 {
4859     static char __pathify_retbuf[VMS_MAXRSS];
4860     unsigned long int retlen;
4861     char *retpath, *cp1, *cp2, *trndir;
4862     unsigned short int trnlnm_iter_count;
4863     STRLEN trnlen;
4864     int sts;
4865
4866     if (!dir || !*dir) {
4867       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4868     }
4869
4870     Newx(trndir, VMS_MAXRSS, char);
4871     if (*dir) strcpy(trndir,dir);
4872     else getcwd(trndir,VMS_MAXRSS - 1);
4873
4874     trnlnm_iter_count = 0;
4875     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4876            && my_trnlnm(trndir,trndir,0)) {
4877       trnlnm_iter_count++;
4878       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4879       trnlen = strlen(trndir);
4880
4881       /* Trap simple rooted lnms, and return lnm:[000000] */
4882       if (!strcmp(trndir+trnlen-2,".]")) {
4883         if (buf) retpath = buf;
4884         else if (ts) Newx(retpath,strlen(dir)+10,char);
4885         else retpath = __pathify_retbuf;
4886         strcpy(retpath,dir);
4887         strcat(retpath,":[000000]");
4888         Safefree(trndir);
4889         return retpath;
4890       }
4891     }
4892
4893     /* At this point we do not work with *dir, but the copy in
4894      * *trndir that is modifiable.
4895      */
4896
4897     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4898       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4899                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4900         retlen = 2 + (*(trndir+1) != '\0');
4901       else {
4902         if ( !(cp1 = strrchr(trndir,'/')) &&
4903              !(cp1 = strrchr(trndir,']')) &&
4904              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4905         if ((cp2 = strchr(cp1,'.')) != NULL &&
4906             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4907              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4908               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4909               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4910           int ver; char *cp3;
4911
4912           /* For EFS or ODS-5 look for the last dot */
4913           if (decc_efs_charset) {
4914             cp2 = strrchr(cp1,'.');
4915           }
4916           if (vms_process_case_tolerant) {
4917               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4918                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4919                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4920                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4921                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4922                             (ver || *cp3)))))) {
4923                 Safefree(trndir);
4924                 set_errno(ENOTDIR);
4925                 set_vaxc_errno(RMS$_DIR);
4926                 return NULL;
4927               }
4928           }
4929           else {
4930               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4931                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4932                   !*(cp2+3) || *(cp2+3) != 'R' ||
4933                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4934                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4935                             (ver || *cp3)))))) {
4936                 Safefree(trndir);
4937                 set_errno(ENOTDIR);
4938                 set_vaxc_errno(RMS$_DIR);
4939                 return NULL;
4940               }
4941           }
4942           retlen = cp2 - trndir + 1;
4943         }
4944         else {  /* No file type present.  Treat the filename as a directory. */
4945           retlen = strlen(trndir) + 1;
4946         }
4947       }
4948       if (buf) retpath = buf;
4949       else if (ts) Newx(retpath,retlen+1,char);
4950       else retpath = __pathify_retbuf;
4951       strncpy(retpath, trndir, retlen-1);
4952       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4953         retpath[retlen-1] = '/';      /* with '/', add it. */
4954         retpath[retlen] = '\0';
4955       }
4956       else retpath[retlen-1] = '\0';
4957     }
4958     else {  /* VMS-style directory spec */
4959       char *esa, *cp;
4960       unsigned long int sts, cmplen, haslower;
4961       struct FAB dirfab = cc$rms_fab;
4962       int dirlen;
4963       rms_setup_nam(savnam);
4964       rms_setup_nam(dirnam);
4965
4966       /* If we've got an explicit filename, we can just shuffle the string. */
4967       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4968              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4969         if ((cp2 = strchr(cp1,'.')) != NULL) {
4970           int ver; char *cp3;
4971           if (vms_process_case_tolerant) {
4972               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4973                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4974                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4975                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4976                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4977                             (ver || *cp3)))))) {
4978                Safefree(trndir);
4979                set_errno(ENOTDIR);
4980                set_vaxc_errno(RMS$_DIR);
4981                return NULL;
4982              }
4983           }
4984           else {
4985               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4986                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4987                   !*(cp2+3) || *(cp2+3) != 'R' ||
4988                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4989                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4990                             (ver || *cp3)))))) {
4991                Safefree(trndir);
4992                set_errno(ENOTDIR);
4993                set_vaxc_errno(RMS$_DIR);
4994                return NULL;
4995              }
4996           }
4997         }
4998         else {  /* No file type, so just draw name into directory part */
4999           for (cp2 = cp1; *cp2; cp2++) ;
5000         }
5001         *cp2 = *cp1;
5002         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5003         *cp1 = '.';
5004         /* We've now got a VMS 'path'; fall through */
5005       }
5006
5007       dirlen = strlen(trndir);
5008       if (trndir[dirlen-1] == ']' ||
5009           trndir[dirlen-1] == '>' ||
5010           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5011         if (buf) retpath = buf;
5012         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5013         else retpath = __pathify_retbuf;
5014         strcpy(retpath,trndir);
5015         Safefree(trndir);
5016         return retpath;
5017       }
5018       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5019       Newx(esa, VMS_MAXRSS, char);
5020       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5021       rms_bind_fab_nam(dirfab, dirnam);
5022       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5023 #ifdef NAM$M_NO_SHORT_UPCASE
5024       if (decc_efs_case_preserve)
5025           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5026 #endif
5027
5028       for (cp = trndir; *cp; cp++)
5029         if (islower(*cp)) { haslower = 1; break; }
5030
5031       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5032         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5033           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5034           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5035         }
5036         if (!sts) {
5037           Safefree(trndir);
5038           Safefree(esa);
5039           set_errno(EVMSERR);
5040           set_vaxc_errno(dirfab.fab$l_sts);
5041           return NULL;
5042         }
5043       }
5044       else {
5045         savnam = dirnam;
5046         /* Does the file really exist? */
5047         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5048           if (dirfab.fab$l_sts != RMS$_FNF) {
5049             int sts1;
5050             sts1 = rms_free_search_context(&dirfab);
5051             Safefree(trndir);
5052             Safefree(esa);
5053             set_errno(EVMSERR);
5054             set_vaxc_errno(dirfab.fab$l_sts);
5055             return NULL;
5056           }
5057           dirnam = savnam; /* No; just work with potential name */
5058         }
5059       }
5060       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5061         /* Yep; check version while we're at it, if it's there. */
5062         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5063         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5064           int sts2;
5065           /* Something other than .DIR[;1].  Bzzt. */
5066           sts2 = rms_free_search_context(&dirfab);
5067           Safefree(trndir);
5068           Safefree(esa);
5069           set_errno(ENOTDIR);
5070           set_vaxc_errno(RMS$_DIR);
5071           return NULL;
5072         }
5073       }
5074       /* OK, the type was fine.  Now pull any file name into the
5075          directory path. */
5076       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5077       else {
5078         cp1 = strrchr(esa,'>');
5079         *(rms_nam_typel(dirnam)) = '>';
5080       }
5081       *cp1 = '.';
5082       *(rms_nam_typel(dirnam) + 1) = '\0';
5083       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5084       if (buf) retpath = buf;
5085       else if (ts) Newx(retpath,retlen,char);
5086       else retpath = __pathify_retbuf;
5087       strcpy(retpath,esa);
5088       Safefree(esa);
5089       sts = rms_free_search_context(&dirfab);
5090       /* $PARSE may have upcased filespec, so convert output to lower
5091        * case if input contained any lowercase characters. */
5092       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5093     }
5094
5095     Safefree(trndir);
5096     return retpath;
5097 }  /* end of do_pathify_dirspec() */
5098 /*}}}*/
5099 /* External entry points */
5100 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5101 { return do_pathify_dirspec(dir,buf,0); }
5102 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5103 { return do_pathify_dirspec(dir,buf,1); }
5104
5105 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5106 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5107 {
5108   static char __tounixspec_retbuf[VMS_MAXRSS];
5109   char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5110   const char *cp2;
5111   int devlen, dirlen, retlen = VMS_MAXRSS;
5112   int expand = 1; /* guarantee room for leading and trailing slashes */
5113   unsigned short int trnlnm_iter_count;
5114   int cmp_rslt;
5115
5116   if (spec == NULL) return NULL;
5117   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5118   if (buf) rslt = buf;
5119   else if (ts) {
5120     retlen = strlen(spec);
5121     cp1 = strchr(spec,'[');
5122     if (!cp1) cp1 = strchr(spec,'<');
5123     if (cp1) {
5124       for (cp1++; *cp1; cp1++) {
5125         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5126         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5127           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5128       }
5129     }
5130     Newx(rslt,retlen+2+2*expand,char);
5131   }
5132   else rslt = __tounixspec_retbuf;
5133
5134   /* New VMS specific format needs translation
5135    * glob passes filenames with trailing '\n' and expects this preserved.
5136    */
5137   if (decc_posix_compliant_pathnames) {
5138     if (strncmp(spec, "\"^UP^", 5) == 0) {
5139       char * uspec;
5140       char *tunix;
5141       int tunix_len;
5142       int nl_flag;
5143
5144       Newx(tunix, VMS_MAXRSS + 1,char);
5145       strcpy(tunix, spec);
5146       tunix_len = strlen(tunix);
5147       nl_flag = 0;
5148       if (tunix[tunix_len - 1] == '\n') {
5149         tunix[tunix_len - 1] = '\"';
5150         tunix[tunix_len] = '\0';
5151         tunix_len--;
5152         nl_flag = 1;
5153       }
5154       uspec = decc$translate_vms(tunix);
5155       Safefree(tunix);
5156       if ((int)uspec > 0) {
5157         strcpy(rslt,uspec);
5158         if (nl_flag) {
5159           strcat(rslt,"\n");
5160         }
5161         else {
5162           /* If we can not translate it, makemaker wants as-is */
5163           strcpy(rslt, spec);
5164         }
5165         return rslt;
5166       }
5167     }
5168   }
5169
5170   cmp_rslt = 0; /* Presume VMS */
5171   cp1 = strchr(spec, '/');
5172   if (cp1 == NULL)
5173     cmp_rslt = 0;
5174
5175     /* Look for EFS ^/ */
5176     if (decc_efs_charset) {
5177       while (cp1 != NULL) {
5178         cp2 = cp1 - 1;
5179         if (*cp2 != '^') {
5180           /* Found illegal VMS, assume UNIX */
5181           cmp_rslt = 1;
5182           break;
5183         }
5184       cp1++;
5185       cp1 = strchr(cp1, '/');
5186     }
5187   }
5188
5189   /* Look for "." and ".." */
5190   if (decc_filename_unix_report) {
5191     if (spec[0] == '.') {
5192       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5193         cmp_rslt = 1;
5194       }
5195       else {
5196         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5197           cmp_rslt = 1;
5198         }
5199       }
5200     }
5201   }
5202   /* This is already UNIX or at least nothing VMS understands */
5203   if (cmp_rslt) {
5204     strcpy(rslt,spec);
5205     return rslt;
5206   }
5207
5208   cp1 = rslt;
5209   cp2 = spec;
5210   dirend = strrchr(spec,']');
5211   if (dirend == NULL) dirend = strrchr(spec,'>');
5212   if (dirend == NULL) dirend = strchr(spec,':');
5213   if (dirend == NULL) {
5214     strcpy(rslt,spec);
5215     return rslt;
5216   }
5217
5218   /* Special case 1 - sys$posix_root = / */
5219 #if __CRTL_VER >= 70000000
5220   if (!decc_disable_posix_root) {
5221     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5222       *cp1 = '/';
5223       cp1++;
5224       cp2 = cp2 + 15;
5225       }
5226   }
5227 #endif
5228
5229   /* Special case 2 - Convert NLA0: to /dev/null */
5230 #if __CRTL_VER < 70000000
5231   cmp_rslt = strncmp(spec,"NLA0:", 5);
5232   if (cmp_rslt != 0)
5233      cmp_rslt = strncmp(spec,"nla0:", 5);
5234 #else
5235   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5236 #endif
5237   if (cmp_rslt == 0) {
5238     strcpy(rslt, "/dev/null");
5239     cp1 = cp1 + 9;
5240     cp2 = cp2 + 5;
5241     if (spec[6] != '\0') {
5242       cp1[9] == '/';
5243       cp1++;
5244       cp2++;
5245     }
5246   }
5247
5248    /* Also handle special case "SYS$SCRATCH:" */
5249 #if __CRTL_VER < 70000000
5250   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5251   if (cmp_rslt != 0)
5252      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5253 #else
5254   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5255 #endif
5256   if (cmp_rslt == 0) {
5257   int islnm;
5258
5259     islnm = my_trnlnm(tmp, "TMP", 0);
5260     if (!islnm) {
5261       strcpy(rslt, "/tmp");
5262       cp1 = cp1 + 4;
5263       cp2 = cp2 + 12;
5264       if (spec[12] != '\0') {
5265         cp1[4] == '/';
5266         cp1++;
5267         cp2++;
5268       }
5269     }
5270   }
5271
5272   if (*cp2 != '[' && *cp2 != '<') {
5273     *(cp1++) = '/';
5274   }
5275   else {  /* the VMS spec begins with directories */
5276     cp2++;
5277     if (*cp2 == ']' || *cp2 == '>') {
5278       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5279       return rslt;
5280     }
5281     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5282       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5283         if (ts) Safefree(rslt);
5284         return NULL;
5285       }
5286       trnlnm_iter_count = 0;
5287       do {
5288         cp3 = tmp;
5289         while (*cp3 != ':' && *cp3) cp3++;
5290         *(cp3++) = '\0';
5291         if (strchr(cp3,']') != NULL) break;
5292         trnlnm_iter_count++;
5293         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5294       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5295       if (ts && !buf &&
5296           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5297         retlen = devlen + dirlen;
5298         Renew(rslt,retlen+1+2*expand,char);
5299         cp1 = rslt;
5300       }
5301       cp3 = tmp;
5302       *(cp1++) = '/';
5303       while (*cp3) {
5304         *(cp1++) = *(cp3++);
5305         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5306       }
5307       *(cp1++) = '/';
5308     }
5309     if ((*cp2 == '^')) {
5310         /* EFS file escape, pass the next character as is */
5311         /* Fix me: HEX encoding for UNICODE not implemented */
5312         cp2++;
5313     }
5314     else if ( *cp2 == '.') {
5315       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5316         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5317         cp2 += 3;
5318       }
5319       else cp2++;
5320     }
5321   }
5322   for (; cp2 <= dirend; cp2++) {
5323     if ((*cp2 == '^')) {
5324         /* EFS file escape, pass the next character as is */
5325         /* Fix me: HEX encoding for UNICODE not implemented */
5326         cp2++;
5327         *(cp1++) = *cp2;
5328     }
5329     if (*cp2 == ':') {
5330       *(cp1++) = '/';
5331       if (*(cp2+1) == '[') cp2++;
5332     }
5333     else if (*cp2 == ']' || *cp2 == '>') {
5334       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5335     }
5336     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5337       *(cp1++) = '/';
5338       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5339         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5340                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5341         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5342             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5343       }
5344       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5345         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5346         cp2 += 2;
5347       }
5348     }
5349     else if (*cp2 == '-') {
5350       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5351         while (*cp2 == '-') {
5352           cp2++;
5353           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5354         }
5355         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5356           if (ts) Safefree(rslt);                        /* filespecs like */
5357           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5358           return NULL;
5359         }
5360       }
5361       else *(cp1++) = *cp2;
5362     }
5363     else *(cp1++) = *cp2;
5364   }
5365   while (*cp2) *(cp1++) = *(cp2++);
5366   *cp1 = '\0';
5367
5368   /* This still leaves /000000/ when working with a
5369    * VMS device root or concealed root.
5370    */
5371   {
5372   int ulen;
5373   char * zeros;
5374
5375       ulen = strlen(rslt);
5376
5377       /* Get rid of "000000/ in rooted filespecs */
5378       if (ulen > 7) {
5379         zeros = strstr(rslt, "/000000/");
5380         if (zeros != NULL) {
5381           int mlen;
5382           mlen = ulen - (zeros - rslt) - 7;
5383           memmove(zeros, &zeros[7], mlen);
5384           ulen = ulen - 7;
5385           rslt[ulen] = '\0';
5386         }
5387       }
5388   }
5389
5390   return rslt;
5391
5392 }  /* end of do_tounixspec() */
5393 /*}}}*/
5394 /* External entry points */
5395 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5396 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5397
5398 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5399
5400 static int posix_to_vmsspec
5401   (char *vmspath, int vmspath_len, const char *unixpath) {
5402 int sts;
5403 struct FAB myfab = cc$rms_fab;
5404 struct NAML mynam = cc$rms_naml;
5405 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5406  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5407 char *esa;
5408 char *vms_delim;
5409 int dir_flag;
5410 int unixlen;
5411
5412   /* If not a posix spec already, convert it */
5413   dir_flag = 0;
5414   unixlen = strlen(unixpath);
5415   if (unixlen == 0) {
5416     vmspath[0] = '\0';
5417     return SS$_NORMAL;
5418   }
5419   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5420     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5421   }
5422   else {
5423     /* This is already a VMS specification, no conversion */
5424     unixlen--;
5425     strncpy(vmspath,unixpath, vmspath_len);
5426   }
5427   vmspath[vmspath_len] = 0;
5428   if (unixpath[unixlen - 1] == '/')
5429   dir_flag = 1;
5430   Newx(esa, VMS_MAXRSS, char);
5431   myfab.fab$l_fna = vmspath;
5432   myfab.fab$b_fns = strlen(vmspath);
5433   myfab.fab$l_naml = &mynam;
5434   mynam.naml$l_esa = NULL;
5435   mynam.naml$b_ess = 0;
5436   mynam.naml$l_long_expand = esa;
5437   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5438   mynam.naml$l_rsa = NULL;
5439   mynam.naml$b_rss = 0;
5440   if (decc_efs_case_preserve)
5441     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5442   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5443
5444   /* Set up the remaining naml fields */
5445   sts = sys$parse(&myfab);
5446
5447   /* It failed! Try again as a UNIX filespec */
5448   if (!(sts & 1)) {
5449     Safefree(esa);
5450     return sts;
5451   }
5452
5453    /* get the Device ID and the FID */
5454    sts = sys$search(&myfab);
5455    /* on any failure, returned the POSIX ^UP^ filespec */
5456    if (!(sts & 1)) {
5457       Safefree(esa);
5458       return sts;
5459    }
5460    specdsc.dsc$a_pointer = vmspath;
5461    specdsc.dsc$w_length = vmspath_len;
5462
5463    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5464    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5465    sts = lib$fid_to_name
5466       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5467
5468   /* on any failure, returned the POSIX ^UP^ filespec */
5469   if (!(sts & 1)) {
5470      /* This can happen if user does not have permission to read directories */
5471      if (strncmp(unixpath,"\"^UP^",5) != 0)
5472        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5473      else
5474        strcpy(vmspath, unixpath);
5475   }
5476   else {
5477     vmspath[specdsc.dsc$w_length] = 0;
5478
5479     /* Are we expecting a directory? */
5480     if (dir_flag != 0) {
5481     int i;
5482     char *eptr;
5483
5484       eptr = NULL;
5485
5486       i = specdsc.dsc$w_length - 1;
5487       while (i > 0) {
5488       int zercnt;
5489         zercnt = 0;
5490         /* Version must be '1' */
5491         if (vmspath[i--] != '1')
5492           break;
5493         /* Version delimiter is one of ".;" */
5494         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5495           break;
5496         i--;
5497         if (vmspath[i--] != 'R')
5498           break;
5499         if (vmspath[i--] != 'I')
5500           break;
5501         if (vmspath[i--] != 'D')
5502           break;
5503         if (vmspath[i--] != '.')
5504           break;
5505         eptr = &vmspath[i+1];
5506         while (i > 0) {
5507           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5508             if (vmspath[i-1] != '^') {
5509               if (zercnt != 6) {
5510                 *eptr = vmspath[i];
5511                 eptr[1] = '\0';
5512                 vmspath[i] = '.';
5513                 break;
5514               }
5515               else {
5516                 /* Get rid of 6 imaginary zero directory filename */
5517                 vmspath[i+1] = '\0';
5518               }
5519             }
5520           }
5521           if (vmspath[i] == '0')
5522             zercnt++;
5523           else
5524             zercnt = 10;
5525           i--;
5526         }
5527         break;
5528       }
5529     }
5530   }
5531   Safefree(esa);
5532   return sts;
5533 }
5534
5535 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5536 static int posix_to_vmsspec_hardway
5537   (char *vmspath, int vmspath_len, const char *unixpath) {
5538
5539 char *esa;
5540 const char *unixptr;
5541 char *vmsptr;
5542 const char *lastslash;
5543 const char *lastdot;
5544 int unixlen;
5545 int vmslen;
5546 int dir_start;
5547 int dir_dot;
5548 int quoted;
5549
5550
5551   unixptr = unixpath;
5552   dir_dot = 0;
5553
5554   /* Ignore leading "/" characters */
5555   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5556     unixptr++;
5557   }
5558   unixlen = strlen(unixptr);
5559
5560   /* Do nothing with blank paths */
5561   if (unixlen == 0) {
5562     vmspath[0] = '\0';
5563     return SS$_NORMAL;
5564   }
5565
5566   lastslash = strrchr(unixptr,'/');
5567   lastdot = strrchr(unixptr,'.');
5568
5569
5570   /* last dot is last dot or past end of string */
5571   if (lastdot == NULL)
5572     lastdot = unixptr + unixlen;
5573
5574   /* if no directories, set last slash to beginning of string */
5575   if (lastslash == NULL) {
5576     lastslash = unixptr;
5577   }
5578   else {
5579     /* Watch out for trailing "." after last slash, still a directory */
5580     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5581       lastslash = unixptr + unixlen;
5582     }
5583
5584     /* Watch out for traiing ".." after last slash, still a directory */
5585     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5586       lastslash = unixptr + unixlen;
5587     }
5588
5589     /* dots in directories are aways escaped */
5590     if (lastdot < lastslash)
5591       lastdot = unixptr + unixlen;
5592   }
5593
5594   /* if (unixptr < lastslash) then we are in a directory */
5595
5596   dir_start = 0;
5597   quoted = 0;
5598
5599   vmsptr = vmspath;
5600   vmslen = 0;
5601
5602   /* This could have a "^UP^ on the front */
5603   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5604     quoted = 1;
5605     unixptr+= 5;
5606   }
5607
5608   /* Start with the UNIX path */
5609   if (*unixptr != '/') {
5610     /* relative paths */
5611     if (lastslash > unixptr) {
5612     int dotdir_seen;
5613
5614       /* skip leading ./ */
5615       dotdir_seen = 0;
5616       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5617         dotdir_seen = 1;
5618         unixptr++;
5619         unixptr++;
5620       }
5621
5622       /* Are we still in a directory? */
5623       if (unixptr <= lastslash) {
5624         *vmsptr++ = '[';
5625         vmslen = 1;
5626         dir_start = 1;
5627
5628         /* if not backing up, then it is relative forward. */
5629         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5630               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5631           *vmsptr++ = '.';
5632           vmslen++;
5633           dir_dot = 1;
5634         }
5635        }
5636        else {
5637          if (dotdir_seen) {
5638            /* Perl wants an empty directory here to tell the difference
5639             * between a DCL commmand and a filename
5640             */
5641           *vmsptr++ = '[';
5642           *vmsptr++ = ']';
5643           vmslen = 2;
5644         }
5645       }
5646     }
5647     else {
5648       /* Handle two special files . and .. */
5649       if (unixptr[0] == '.') {
5650         if (unixptr[1] == '\0') {
5651           *vmsptr++ = '[';
5652           *vmsptr++ = ']';
5653           vmslen += 2;
5654           *vmsptr++ = '\0';
5655           return SS$_NORMAL;
5656         }
5657         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5658           *vmsptr++ = '[';
5659           *vmsptr++ = '-';
5660           *vmsptr++ = ']';
5661           vmslen += 3;
5662           *vmsptr++ = '\0';
5663           return SS$_NORMAL;
5664         }
5665       }
5666     }
5667   }
5668   else {        /* Absolute PATH handling */
5669   int sts;
5670   char * nextslash;
5671   int seg_len;
5672     /* Need to find out where root is */
5673
5674     /* In theory, this procedure should never get an absolute POSIX pathname
5675      * that can not be found on the POSIX root.
5676      * In practice, that can not be relied on, and things will show up
5677      * here that are a VMS device name or concealed logical name instead.
5678      * So to make things work, this procedure must be tolerant.
5679      */
5680     Newx(esa, vmspath_len, char);
5681
5682     sts = SS$_NORMAL;
5683     nextslash = strchr(&unixptr[1],'/');
5684     seg_len = 0;
5685     if (nextslash != NULL) {
5686       seg_len = nextslash - &unixptr[1];
5687       strncpy(vmspath, unixptr, seg_len + 1);
5688       vmspath[seg_len+1] = 0;
5689       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5690     }
5691
5692     if (sts & 1) {
5693       /* This is verified to be a real path */
5694
5695       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5696       strcpy(vmspath, esa);
5697       vmslen = strlen(vmspath);
5698       vmsptr = vmspath + vmslen;
5699       unixptr++;
5700       if (unixptr < lastslash) {
5701       char * rptr;
5702         vmsptr--;
5703         *vmsptr++ = '.';
5704         dir_start = 1;
5705         dir_dot = 1;
5706         if (vmslen > 7) {
5707         int cmp;
5708           rptr = vmsptr - 7;
5709           cmp = strcmp(rptr,"000000.");
5710           if (cmp == 0) {
5711             vmslen -= 7;
5712             vmsptr -= 7;
5713             vmsptr[1] = '\0';
5714           } /* removing 6 zeros */
5715         } /* vmslen < 7, no 6 zeros possible */
5716       } /* Not in a directory */
5717     } /* end of verified real path handling */
5718     else {
5719     int add_6zero;
5720     int islnm;
5721
5722       /* Ok, we have a device or a concealed root that is not in POSIX
5723        * or we have garbage.  Make the best of it.
5724        */
5725
5726       /* Posix to VMS destroyed this, so copy it again */
5727       strncpy(vmspath, &unixptr[1], seg_len);
5728       vmspath[seg_len] = 0;
5729       vmslen = seg_len;
5730       vmsptr = &vmsptr[vmslen];
5731       islnm = 0;
5732
5733       /* Now do we need to add the fake 6 zero directory to it? */
5734       add_6zero = 1;
5735       if ((*lastslash == '/') && (nextslash < lastslash)) {
5736         /* No there is another directory */
5737         add_6zero = 0;
5738       }
5739       else {
5740       int trnend;
5741
5742         /* now we have foo:bar or foo:[000000]bar to decide from */
5743         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5744         trnend = islnm ? islnm - 1 : 0;
5745
5746         /* if this was a logical name, ']' or '>' must be present */
5747         /* if not a logical name, then assume a device and hope. */
5748         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5749
5750         /* if log name and trailing '.' then rooted - treat as device */
5751         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5752
5753         /* Fix me, if not a logical name, a device lookup should be
5754          * done to see if the device is file structured.  If the device
5755          * is not file structured, the 6 zeros should not be put on.
5756          *
5757          * As it is, perl is occasionally looking for dev:[000000]tty.
5758          * which looks a little strange.
5759          */
5760
5761         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5762           /* No real directory present */
5763           add_6zero = 1;
5764         }
5765       }
5766
5767       /* Put the device delimiter on */
5768       *vmsptr++ = ':';
5769       vmslen++;
5770       unixptr = nextslash;
5771       unixptr++;
5772
5773       /* Start directory if needed */
5774       if (!islnm || add_6zero) {
5775         *vmsptr++ = '[';
5776         vmslen++;
5777         dir_start = 1;
5778       }
5779
5780       /* add fake 000000] if needed */
5781       if (add_6zero) {
5782         *vmsptr++ = '0';
5783         *vmsptr++ = '0';
5784         *vmsptr++ = '0';
5785         *vmsptr++ = '0';
5786         *vmsptr++ = '0';
5787         *vmsptr++ = '0';
5788         *vmsptr++ = ']';
5789         vmslen += 7;
5790         dir_start = 0;
5791       }
5792
5793     } /* non-POSIX translation */
5794     Safefree(esa);
5795   } /* End of relative/absolute path handling */
5796
5797   while ((*unixptr) && (vmslen < vmspath_len)){
5798   int dash_flag;
5799
5800     dash_flag = 0;
5801
5802     if (dir_start != 0) {
5803
5804       /* First characters in a directory are handled special */
5805       while ((*unixptr == '/') ||
5806              ((*unixptr == '.') &&
5807               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5808       int loop_flag;
5809
5810         loop_flag = 0;
5811
5812         /* Skip redundant / in specification */
5813         while ((*unixptr == '/') && (dir_start != 0)) {
5814           loop_flag = 1;
5815           unixptr++;
5816           if (unixptr == lastslash)
5817             break;
5818         }
5819         if (unixptr == lastslash)
5820           break;
5821
5822         /* Skip redundant ./ characters */
5823         while ((*unixptr == '.') &&
5824                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5825           loop_flag = 1;
5826           unixptr++;
5827           if (unixptr == lastslash)
5828             break;
5829           if (*unixptr == '/')
5830             unixptr++;
5831         }
5832         if (unixptr == lastslash)
5833           break;
5834
5835         /* Skip redundant ../ characters */
5836         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5837              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5838           /* Set the backing up flag */
5839           loop_flag = 1;
5840           dir_dot = 0;
5841           dash_flag = 1;
5842           *vmsptr++ = '-';
5843           vmslen++;
5844           unixptr++; /* first . */
5845           unixptr++; /* second . */
5846           if (unixptr == lastslash)
5847             break;
5848           if (*unixptr == '/') /* The slash */
5849             unixptr++;
5850         }
5851         if (unixptr == lastslash)
5852           break;
5853
5854         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5855         /* Not needed when VMS is pretending to be UNIX. */
5856
5857         /* Is this loop stuck because of too many dots? */
5858         if (loop_flag == 0) {
5859           /* Exit the loop and pass the rest through */
5860           break;
5861         }
5862       }
5863
5864       /* Are we done with directories yet? */
5865       if (unixptr >= lastslash) {
5866
5867         /* Watch out for trailing dots */
5868         if (dir_dot != 0) {
5869             vmslen --;
5870             vmsptr--;
5871         }
5872         *vmsptr++ = ']';
5873         vmslen++;
5874         dash_flag = 0;
5875         dir_start = 0;
5876         if (*unixptr == '/')
5877           unixptr++;
5878       }
5879       else {
5880         /* Have we stopped backing up? */
5881         if (dash_flag) {
5882           *vmsptr++ = '.';
5883           vmslen++;
5884           dash_flag = 0;
5885           /* dir_start continues to be = 1 */
5886         }
5887         if (*unixptr == '-') {
5888           *vmsptr++ = '^';
5889           *vmsptr++ = *unixptr++;
5890           vmslen += 2;
5891           dir_start = 0;
5892
5893           /* Now are we done with directories yet? */
5894           if (unixptr >= lastslash) {
5895
5896             /* Watch out for trailing dots */
5897             if (dir_dot != 0) {
5898               vmslen --;
5899               vmsptr--;
5900             }
5901
5902             *vmsptr++ = ']';
5903             vmslen++;
5904             dash_flag = 0;
5905             dir_start = 0;
5906           }
5907         }
5908       }
5909     }
5910
5911     /* All done? */
5912     if (*unixptr == '\0')
5913       break;
5914
5915     /* Normal characters - More EFS work probably needed */
5916     dir_start = 0;
5917     dir_dot = 0;
5918
5919     switch(*unixptr) {
5920     case '/':
5921         /* remove multiple / */
5922         while (unixptr[1] == '/') {
5923            unixptr++;
5924         }
5925         if (unixptr == lastslash) {
5926           /* Watch out for trailing dots */
5927           if (dir_dot != 0) {
5928             vmslen --;
5929             vmsptr--;
5930           }
5931           *vmsptr++ = ']';
5932         }
5933         else {
5934           dir_start = 1;
5935           *vmsptr++ = '.';
5936           dir_dot = 1;
5937
5938           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5939           /* Not needed when VMS is pretending to be UNIX. */
5940
5941         }
5942         dash_flag = 0;
5943         if (*unixptr != '\0')
5944           unixptr++;
5945         vmslen++;
5946         break;
5947     case '?':
5948         *vmsptr++ = '%';
5949         vmslen++;
5950         unixptr++;
5951         break;
5952     case ' ':
5953         *vmsptr++ = '^';
5954         *vmsptr++ = '_';
5955         vmslen += 2;
5956         unixptr++;
5957         break;
5958     case '.':
5959         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5960           *vmsptr++ = '^';
5961           *vmsptr++ = '.';
5962           vmslen += 2;
5963           unixptr++;
5964
5965           /* trailing dot ==> '^..' on VMS */
5966           if (*unixptr == '\0') {
5967             *vmsptr++ = '.';
5968             vmslen++;
5969           }
5970           *vmsptr++ = *unixptr++;
5971           vmslen ++;
5972         }
5973         if (quoted && (unixptr[1] == '\0')) {
5974           unixptr++;
5975           break;
5976         }
5977         *vmsptr++ = '^';
5978         *vmsptr++ = *unixptr++;
5979         vmslen += 2;
5980         break;
5981     case '~':
5982     case ';':
5983     case '\\':
5984         *vmsptr++ = '^';
5985         *vmsptr++ = *unixptr++;
5986         vmslen += 2;
5987         break;
5988     default:
5989         if (*unixptr != '\0') {
5990           *vmsptr++ = *unixptr++;
5991           vmslen++;
5992         }
5993         break;
5994     }
5995   }
5996
5997   /* Make sure directory is closed */
5998   if (unixptr == lastslash) {
5999     char *vmsptr2;
6000     vmsptr2 = vmsptr - 1;
6001
6002     if (*vmsptr2 != ']') {
6003       *vmsptr2--;
6004
6005       /* directories do not end in a dot bracket */
6006       if (*vmsptr2 == '.') {
6007         vmsptr2--;
6008
6009         /* ^. is allowed */
6010         if (*vmsptr2 != '^') {
6011           vmsptr--; /* back up over the dot */
6012         }
6013       }
6014       *vmsptr++ = ']';
6015     }
6016   }
6017   else {
6018     char *vmsptr2;
6019     /* Add a trailing dot if a file with no extension */
6020     vmsptr2 = vmsptr - 1;
6021     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6022         (*lastdot != '.')) {
6023         *vmsptr++ = '.';
6024         vmslen++;
6025     }
6026   }
6027
6028   *vmsptr = '\0';
6029   return SS$_NORMAL;
6030 }
6031 #endif
6032
6033 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6034 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6035   static char __tovmsspec_retbuf[VMS_MAXRSS];
6036   char *rslt, *dirend;
6037   char *lastdot;
6038   char *vms_delim;
6039   register char *cp1;
6040   const char *cp2;
6041   unsigned long int infront = 0, hasdir = 1;
6042   int rslt_len;
6043   int no_type_seen;
6044
6045   if (path == NULL) return NULL;
6046   rslt_len = VMS_MAXRSS;
6047   if (buf) rslt = buf;
6048   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6049   else rslt = __tovmsspec_retbuf;
6050   if (strpbrk(path,"]:>") ||
6051       (dirend = strrchr(path,'/')) == NULL) {
6052     if (path[0] == '.') {
6053       if (path[1] == '\0') strcpy(rslt,"[]");
6054       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6055       else strcpy(rslt,path); /* probably garbage */
6056     }
6057     else strcpy(rslt,path);
6058     return rslt;
6059   }
6060
6061    /* Posix specifications are now a native VMS format */
6062   /*--------------------------------------------------*/
6063 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6064   if (decc_posix_compliant_pathnames) {
6065     if (strncmp(path,"\"^UP^",5) == 0) {
6066       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6067       return rslt;
6068     }
6069   }
6070 #endif
6071
6072   vms_delim = strpbrk(path,"]:>");
6073
6074   if ((vms_delim != NULL) ||
6075       ((dirend = strrchr(path,'/')) == NULL)) {
6076
6077     /* VMS special characters found! */
6078
6079     if (path[0] == '.') {
6080       if (path[1] == '\0') strcpy(rslt,"[]");
6081       else if (path[1] == '.' && path[2] == '\0')
6082         strcpy(rslt,"[-]");
6083
6084       /* Dot preceeding a device or directory ? */
6085       else {
6086         /* If not in POSIX mode, pass it through and hope it works */
6087 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6088         if (!decc_posix_compliant_pathnames)
6089           strcpy(rslt,path); /* probably garbage */
6090         else
6091           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6092 #else
6093         strcpy(rslt,path); /* probably garbage */
6094 #endif
6095       }
6096     }
6097     else {
6098
6099        /* If no VMS characters and in POSIX mode, convert it!
6100         * This is the easiest way to get directory specifications
6101         * handled correctly in POSIX mode
6102         */
6103 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6104       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6105         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6106       else {
6107         /* No unix path separators - presume VMS already */
6108         strcpy(rslt,path);
6109       }
6110 #else
6111       strcpy(rslt,path); /* probably garbage */
6112 #endif
6113     }
6114     return rslt;
6115   }
6116
6117 /* If POSIX mode active, handle the conversion */
6118 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6119   if (decc_posix_compliant_pathnames) {
6120     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6121     return rslt;
6122   }
6123 #endif
6124
6125   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6126     if (!*(dirend+2)) dirend +=2;
6127     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6128     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6129   }
6130
6131   cp1 = rslt;
6132   cp2 = path;
6133   lastdot = strrchr(cp2,'.');
6134   if (*cp2 == '/') {
6135     char *trndev;
6136     int islnm, rooted;
6137     STRLEN trnend;
6138
6139     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6140     if (!*(cp2+1)) {
6141       if (decc_disable_posix_root) {
6142         strcpy(rslt,"sys$disk:[000000]");
6143       }
6144       else {
6145         strcpy(rslt,"sys$posix_root:[000000]");
6146       }
6147       return rslt;
6148     }
6149     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6150     *cp1 = '\0';
6151     Newx(trndev, VMS_MAXRSS, char);
6152     islnm =  my_trnlnm(rslt,trndev,0);
6153
6154      /* DECC special handling */
6155     if (!islnm) {
6156       if (strcmp(rslt,"bin") == 0) {
6157         strcpy(rslt,"sys$system");
6158         cp1 = rslt + 10;
6159         *cp1 = 0;
6160         islnm =  my_trnlnm(rslt,trndev,0);
6161       }
6162       else if (strcmp(rslt,"tmp") == 0) {
6163         strcpy(rslt,"sys$scratch");
6164         cp1 = rslt + 11;
6165         *cp1 = 0;
6166         islnm =  my_trnlnm(rslt,trndev,0);
6167       }
6168       else if (!decc_disable_posix_root) {
6169         strcpy(rslt, "sys$posix_root");
6170         cp1 = rslt + 13;
6171         *cp1 = 0;
6172         cp2 = path;
6173         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6174         islnm =  my_trnlnm(rslt,trndev,0);
6175       }
6176       else if (strcmp(rslt,"dev") == 0) {
6177         if (strncmp(cp2,"/null", 5) == 0) {
6178           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6179             strcpy(rslt,"NLA0");
6180             cp1 = rslt + 4;
6181             *cp1 = 0;
6182             cp2 = cp2 + 5;
6183             islnm =  my_trnlnm(rslt,trndev,0);
6184           }
6185         }
6186       }
6187     }
6188
6189     trnend = islnm ? strlen(trndev) - 1 : 0;
6190     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6191     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6192     /* If the first element of the path is a logical name, determine
6193      * whether it has to be translated so we can add more directories. */
6194     if (!islnm || rooted) {
6195       *(cp1++) = ':';
6196       *(cp1++) = '[';
6197       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6198       else cp2++;
6199     }
6200     else {
6201       if (cp2 != dirend) {
6202         strcpy(rslt,trndev);
6203         cp1 = rslt + trnend;
6204         if (*cp2 != 0) {
6205           *(cp1++) = '.';
6206           cp2++;
6207         }
6208       }
6209       else {
6210         if (decc_disable_posix_root) {
6211           *(cp1++) = ':';
6212           hasdir = 0;
6213         }
6214       }
6215     }
6216     Safefree(trndev);
6217   }
6218   else {
6219     *(cp1++) = '[';
6220     if (*cp2 == '.') {
6221       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6222         cp2 += 2;         /* skip over "./" - it's redundant */
6223         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6224       }
6225       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6226         *(cp1++) = '-';                                 /* "../" --> "-" */
6227         cp2 += 3;
6228       }
6229       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6230                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6231         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6232         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6233         cp2 += 4;
6234       }
6235       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6236         /* Escape the extra dots in EFS file specifications */
6237         *(cp1++) = '^';
6238       }
6239       if (cp2 > dirend) cp2 = dirend;
6240     }
6241     else *(cp1++) = '.';
6242   }
6243   for (; cp2 < dirend; cp2++) {
6244     if (*cp2 == '/') {
6245       if (*(cp2-1) == '/') continue;
6246       if (*(cp1-1) != '.') *(cp1++) = '.';
6247       infront = 0;
6248     }
6249     else if (!infront && *cp2 == '.') {
6250       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6251       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6252       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6253         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6254         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6255         else {  /* back up over previous directory name */
6256           cp1--;
6257           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6258           if (*(cp1-1) == '[') {
6259             memcpy(cp1,"000000.",7);
6260             cp1 += 7;
6261           }
6262         }
6263         cp2 += 2;
6264         if (cp2 == dirend) break;
6265       }
6266       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6267                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6268         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6269         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6270         if (!*(cp2+3)) {
6271           *(cp1++) = '.';  /* Simulate trailing '/' */
6272           cp2 += 2;  /* for loop will incr this to == dirend */
6273         }
6274         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6275       }
6276       else {
6277         if (decc_efs_charset == 0)
6278           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6279         else {
6280           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6281           *(cp1++) = '.';
6282         }
6283       }
6284     }
6285     else {
6286       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6287       if (*cp2 == '.') {
6288         if (decc_efs_charset == 0)
6289           *(cp1++) = '_';
6290         else {
6291           *(cp1++) = '^';
6292           *(cp1++) = '.';
6293         }
6294       }
6295       else                  *(cp1++) =  *cp2;
6296       infront = 1;
6297     }
6298   }
6299   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6300   if (hasdir) *(cp1++) = ']';
6301   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6302   /* fixme for ODS5 */
6303   no_type_seen = 0;
6304   if (cp2 > lastdot)
6305     no_type_seen = 1;
6306   while (*cp2) {
6307     switch(*cp2) {
6308     case '?':
6309         *(cp1++) = '%';
6310         cp2++;
6311     case ' ':
6312         *(cp1)++ = '^';
6313         *(cp1)++ = '_';
6314         cp2++;
6315         break;
6316     case '.':
6317         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6318             decc_readdir_dropdotnotype) {
6319           *(cp1)++ = '^';
6320           *(cp1)++ = '.';
6321           cp2++;
6322
6323           /* trailing dot ==> '^..' on VMS */
6324           if (*cp2 == '\0') {
6325             *(cp1++) = '.';
6326             no_type_seen = 0;
6327           }
6328         }
6329         else {
6330           *(cp1++) = *(cp2++);
6331           no_type_seen = 0;
6332         }
6333         break;
6334     case '\"':
6335     case '~':
6336     case '`':
6337     case '!':
6338     case '#':
6339     case '%':
6340     case '^':
6341     case '&':
6342     case '(':
6343     case ')':
6344     case '=':
6345     case '+':
6346     case '\'':
6347     case '@':
6348     case '[':
6349     case ']':
6350     case '{':
6351     case '}':
6352     case ':':
6353     case '\\':
6354     case '|':
6355     case '<':
6356     case '>':
6357         *(cp1++) = '^';
6358         *(cp1++) = *(cp2++);
6359         break;
6360     case ';':
6361         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6362          * which is wrong.  UNIX notation should be ".dir. unless
6363          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6364          * changing this behavior could break more things at this time.
6365          * efs character set effectively does not allow "." to be a version
6366          * delimiter as a further complication about changing this.
6367          */
6368         if (decc_filename_unix_report != 0) {
6369           *(cp1++) = '^';
6370         }
6371         *(cp1++) = *(cp2++);
6372         break;
6373     default:
6374         *(cp1++) = *(cp2++);
6375     }
6376   }
6377   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6378   char *lcp1;
6379     lcp1 = cp1;
6380     lcp1--;
6381      /* Fix me for "^]", but that requires making sure that you do
6382       * not back up past the start of the filename
6383       */
6384     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6385       *cp1++ = '.';
6386   }
6387   *cp1 = '\0';
6388
6389   return rslt;
6390
6391 }  /* end of do_tovmsspec() */
6392 /*}}}*/
6393 /* External entry points */
6394 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6395 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6396
6397 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6398 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6399   static char __tovmspath_retbuf[VMS_MAXRSS];
6400   int vmslen;
6401   char *pathified, *vmsified, *cp;
6402
6403   if (path == NULL) return NULL;
6404   Newx(pathified, VMS_MAXRSS, char);
6405   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6406     Safefree(pathified);
6407     return NULL;
6408   }
6409   Newx(vmsified, VMS_MAXRSS, char);
6410   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6411     Safefree(pathified);
6412     Safefree(vmsified);
6413     return NULL;
6414   }
6415   Safefree(pathified);
6416   if (buf) {
6417     Safefree(vmsified);
6418     return buf;
6419   }
6420   else if (ts) {
6421     vmslen = strlen(vmsified);
6422     Newx(cp,vmslen+1,char);
6423     memcpy(cp,vmsified,vmslen);
6424     cp[vmslen] = '\0';
6425     Safefree(vmsified);
6426     return cp;
6427   }
6428   else {
6429     strcpy(__tovmspath_retbuf,vmsified);
6430     Safefree(vmsified);
6431     return __tovmspath_retbuf;
6432   }
6433
6434 }  /* end of do_tovmspath() */
6435 /*}}}*/
6436 /* External entry points */
6437 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6438 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6439
6440
6441 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6442 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6443   static char __tounixpath_retbuf[VMS_MAXRSS];
6444   int unixlen;
6445   char *pathified, *unixified, *cp;
6446
6447   if (path == NULL) return NULL;
6448   Newx(pathified, VMS_MAXRSS, char);
6449   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6450     Safefree(pathified);
6451     return NULL;
6452   }
6453   Newx(unixified, VMS_MAXRSS, char);
6454   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6455     Safefree(pathified);
6456     Safefree(unixified);
6457     return NULL;
6458   }
6459   Safefree(pathified);
6460   if (buf) {
6461     Safefree(unixified);
6462     return buf;
6463   }
6464   else if (ts) {
6465     unixlen = strlen(unixified);
6466     Newx(cp,unixlen+1,char);
6467     memcpy(cp,unixified,unixlen);
6468     cp[unixlen] = '\0';
6469     Safefree(unixified);
6470     return cp;
6471   }
6472   else {
6473     strcpy(__tounixpath_retbuf,unixified);
6474     Safefree(unixified);
6475     return __tounixpath_retbuf;
6476   }
6477
6478 }  /* end of do_tounixpath() */
6479 /*}}}*/
6480 /* External entry points */
6481 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6482 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6483
6484 /*
6485  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6486  *
6487  *****************************************************************************
6488  *                                                                           *
6489  *  Copyright (C) 1989-1994 by                                               *
6490  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6491  *                                                                           *
6492  *  Permission is hereby  granted for the reproduction of this software,     *
6493  *  on condition that this copyright notice is included in the reproduction, *
6494  *  and that such reproduction is not for purposes of profit or material     *
6495  *  gain.                                                                    *
6496  *                                                                           *
6497  *  27-Aug-1994 Modified for inclusion in perl5                              *
6498  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6499  *****************************************************************************
6500  */
6501
6502 /*
6503  * getredirection() is intended to aid in porting C programs
6504  * to VMS (Vax-11 C).  The native VMS environment does not support
6505  * '>' and '<' I/O redirection, or command line wild card expansion,
6506  * or a command line pipe mechanism using the '|' AND background
6507  * command execution '&'.  All of these capabilities are provided to any
6508  * C program which calls this procedure as the first thing in the
6509  * main program.
6510  * The piping mechanism will probably work with almost any 'filter' type
6511  * of program.  With suitable modification, it may useful for other
6512  * portability problems as well.
6513  *
6514  * Author:  Mark Pizzolato      mark@infocomm.com
6515  */
6516 struct list_item
6517     {
6518     struct list_item *next;
6519     char *value;
6520     };
6521
6522 static void add_item(struct list_item **head,
6523                      struct list_item **tail,
6524                      char *value,
6525                      int *count);
6526
6527 static void mp_expand_wild_cards(pTHX_ char *item,
6528                                 struct list_item **head,
6529                                 struct list_item **tail,
6530                                 int *count);
6531
6532 static int background_process(pTHX_ int argc, char **argv);
6533
6534 static void pipe_and_fork(pTHX_ char **cmargv);
6535
6536 /*{{{ void getredirection(int *ac, char ***av)*/
6537 static void
6538 mp_getredirection(pTHX_ int *ac, char ***av)
6539 /*
6540  * Process vms redirection arg's.  Exit if any error is seen.
6541  * If getredirection() processes an argument, it is erased
6542  * from the vector.  getredirection() returns a new argc and argv value.
6543  * In the event that a background command is requested (by a trailing "&"),
6544  * this routine creates a background subprocess, and simply exits the program.
6545  *
6546  * Warning: do not try to simplify the code for vms.  The code
6547  * presupposes that getredirection() is called before any data is
6548  * read from stdin or written to stdout.
6549  *
6550  * Normal usage is as follows:
6551  *
6552  *      main(argc, argv)
6553  *      int             argc;
6554  *      char            *argv[];
6555  *      {
6556  *              getredirection(&argc, &argv);
6557  *      }
6558  */
6559 {
6560     int                 argc = *ac;     /* Argument Count         */
6561     char                **argv = *av;   /* Argument Vector        */
6562     char                *ap;            /* Argument pointer       */
6563     int                 j;              /* argv[] index           */
6564     int                 item_count = 0; /* Count of Items in List */
6565     struct list_item    *list_head = 0; /* First Item in List       */
6566     struct list_item    *list_tail;     /* Last Item in List        */
6567     char                *in = NULL;     /* Input File Name          */
6568     char                *out = NULL;    /* Output File Name         */
6569     char                *outmode = "w"; /* Mode to Open Output File */
6570     char                *err = NULL;    /* Error File Name          */
6571     char                *errmode = "w"; /* Mode to Open Error File  */
6572     int                 cmargc = 0;     /* Piped Command Arg Count  */
6573     char                **cmargv = NULL;/* Piped Command Arg Vector */
6574
6575     /*
6576      * First handle the case where the last thing on the line ends with
6577      * a '&'.  This indicates the desire for the command to be run in a
6578      * subprocess, so we satisfy that desire.
6579      */
6580     ap = argv[argc-1];
6581     if (0 == strcmp("&", ap))
6582        exit(background_process(aTHX_ --argc, argv));
6583     if (*ap && '&' == ap[strlen(ap)-1])
6584         {
6585         ap[strlen(ap)-1] = '\0';
6586        exit(background_process(aTHX_ argc, argv));
6587         }
6588     /*
6589      * Now we handle the general redirection cases that involve '>', '>>',
6590      * '<', and pipes '|'.
6591      */
6592     for (j = 0; j < argc; ++j)
6593         {
6594         if (0 == strcmp("<", argv[j]))
6595             {
6596             if (j+1 >= argc)
6597                 {
6598                 fprintf(stderr,"No input file after < on command line");
6599                 exit(LIB$_WRONUMARG);
6600                 }
6601             in = argv[++j];
6602             continue;
6603             }
6604         if ('<' == *(ap = argv[j]))
6605             {
6606             in = 1 + ap;
6607             continue;
6608             }
6609         if (0 == strcmp(">", ap))
6610             {
6611             if (j+1 >= argc)
6612                 {
6613                 fprintf(stderr,"No output file after > on command line");
6614                 exit(LIB$_WRONUMARG);
6615                 }
6616             out = argv[++j];
6617             continue;
6618             }
6619         if ('>' == *ap)
6620             {
6621             if ('>' == ap[1])
6622                 {
6623                 outmode = "a";
6624                 if ('\0' == ap[2])
6625                     out = argv[++j];
6626                 else
6627                     out = 2 + ap;
6628                 }
6629             else
6630                 out = 1 + ap;
6631             if (j >= argc)
6632                 {
6633                 fprintf(stderr,"No output file after > or >> on command line");
6634                 exit(LIB$_WRONUMARG);
6635                 }
6636             continue;
6637             }
6638         if (('2' == *ap) && ('>' == ap[1]))
6639             {
6640             if ('>' == ap[2])
6641                 {
6642                 errmode = "a";
6643                 if ('\0' == ap[3])
6644                     err = argv[++j];
6645                 else
6646                     err = 3 + ap;
6647                 }
6648             else
6649                 if ('\0' == ap[2])
6650                     err = argv[++j];
6651                 else
6652                     err = 2 + ap;
6653             if (j >= argc)
6654                 {
6655                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6656                 exit(LIB$_WRONUMARG);
6657                 }
6658             continue;
6659             }
6660         if (0 == strcmp("|", argv[j]))
6661             {
6662             if (j+1 >= argc)
6663                 {
6664                 fprintf(stderr,"No command into which to pipe on command line");
6665                 exit(LIB$_WRONUMARG);
6666                 }
6667             cmargc = argc-(j+1);
6668             cmargv = &argv[j+1];
6669             argc = j;
6670             continue;
6671             }
6672         if ('|' == *(ap = argv[j]))
6673             {
6674             ++argv[j];
6675             cmargc = argc-j;
6676             cmargv = &argv[j];
6677             argc = j;
6678             continue;
6679             }
6680         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6681         }
6682     /*
6683      * Allocate and fill in the new argument vector, Some Unix's terminate
6684      * the list with an extra null pointer.
6685      */
6686     Newx(argv, item_count+1, char *);
6687     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6688     *av = argv;
6689     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6690         argv[j] = list_head->value;
6691     *ac = item_count;
6692     if (cmargv != NULL)
6693         {
6694         if (out != NULL)
6695             {
6696             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6697             exit(LIB$_INVARGORD);
6698             }
6699         pipe_and_fork(aTHX_ cmargv);
6700         }
6701
6702     /* Check for input from a pipe (mailbox) */
6703
6704     if (in == NULL && 1 == isapipe(0))
6705         {
6706         char mbxname[L_tmpnam];
6707         long int bufsize;
6708         long int dvi_item = DVI$_DEVBUFSIZ;
6709         $DESCRIPTOR(mbxnam, "");
6710         $DESCRIPTOR(mbxdevnam, "");
6711
6712         /* Input from a pipe, reopen it in binary mode to disable       */
6713         /* carriage control processing.                                 */
6714
6715         fgetname(stdin, mbxname);
6716         mbxnam.dsc$a_pointer = mbxname;
6717         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6718         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6719         mbxdevnam.dsc$a_pointer = mbxname;
6720         mbxdevnam.dsc$w_length = sizeof(mbxname);
6721         dvi_item = DVI$_DEVNAM;
6722         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6723         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6724         set_errno(0);
6725         set_vaxc_errno(1);
6726         freopen(mbxname, "rb", stdin);
6727         if (errno != 0)
6728             {
6729             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6730             exit(vaxc$errno);
6731             }
6732         }
6733     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6734         {
6735         fprintf(stderr,"Can't open input file %s as stdin",in);
6736         exit(vaxc$errno);
6737         }
6738     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6739         {
6740         fprintf(stderr,"Can't open output file %s as stdout",out);
6741         exit(vaxc$errno);
6742         }
6743         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6744
6745     if (err != NULL) {
6746         if (strcmp(err,"&1") == 0) {
6747             dup2(fileno(stdout), fileno(stderr));
6748             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6749         } else {
6750         FILE *tmperr;
6751         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6752             {
6753             fprintf(stderr,"Can't open error file %s as stderr",err);
6754             exit(vaxc$errno);
6755             }
6756             fclose(tmperr);
6757            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6758                 {
6759                 exit(vaxc$errno);
6760                 }
6761             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6762         }
6763         }
6764 #ifdef ARGPROC_DEBUG
6765     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6766     for (j = 0; j < *ac;  ++j)
6767         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6768 #endif
6769    /* Clear errors we may have hit expanding wildcards, so they don't
6770       show up in Perl's $! later */
6771    set_errno(0); set_vaxc_errno(1);
6772 }  /* end of getredirection() */
6773 /*}}}*/
6774
6775 static void add_item(struct list_item **head,
6776                      struct list_item **tail,
6777                      char *value,
6778                      int *count)
6779 {
6780     if (*head == 0)
6781         {
6782         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6783         *tail = *head;
6784         }
6785     else {
6786         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6787         *tail = (*tail)->next;
6788         }
6789     (*tail)->value = value;
6790     ++(*count);
6791 }
6792
6793 static void mp_expand_wild_cards(pTHX_ char *item,
6794                               struct list_item **head,
6795                               struct list_item **tail,
6796                               int *count)
6797 {
6798 int expcount = 0;
6799 unsigned long int context = 0;
6800 int isunix = 0;
6801 int item_len = 0;
6802 char *had_version;
6803 char *had_device;
6804 int had_directory;
6805 char *devdir,*cp;
6806 char *vmsspec;
6807 $DESCRIPTOR(filespec, "");
6808 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6809 $DESCRIPTOR(resultspec, "");
6810 unsigned long int lff_flags = 0;
6811 int sts;
6812
6813 #ifdef VMS_LONGNAME_SUPPORT
6814     lff_flags = LIB$M_FIL_LONG_NAMES;
6815 #endif
6816
6817     for (cp = item; *cp; cp++) {
6818         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6819         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6820     }
6821     if (!*cp || isspace(*cp))
6822         {
6823         add_item(head, tail, item, count);
6824         return;
6825         }
6826     else
6827         {
6828      /* "double quoted" wild card expressions pass as is */
6829      /* From DCL that means using e.g.:                  */
6830      /* perl program """perl.*"""                        */
6831      item_len = strlen(item);
6832      if ( '"' == *item && '"' == item[item_len-1] )
6833        {
6834        item++;
6835        item[item_len-2] = '\0';
6836        add_item(head, tail, item, count);
6837        return;
6838        }
6839      }
6840     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6841     resultspec.dsc$b_class = DSC$K_CLASS_D;
6842     resultspec.dsc$a_pointer = NULL;
6843     Newx(vmsspec, VMS_MAXRSS, char);
6844     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6845       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6846     if (!isunix || !filespec.dsc$a_pointer)
6847       filespec.dsc$a_pointer = item;
6848     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6849     /*
6850      * Only return version specs, if the caller specified a version
6851      */
6852     had_version = strchr(item, ';');
6853     /*
6854      * Only return device and directory specs, if the caller specifed either.
6855      */
6856     had_device = strchr(item, ':');
6857     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6858
6859     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6860                                  (&filespec, &resultspec, &context,
6861                                   &defaultspec, 0, 0, &lff_flags)))
6862         {
6863         char *string;
6864         char *c;
6865
6866         Newx(string,resultspec.dsc$w_length+1,char);
6867         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6868         string[resultspec.dsc$w_length] = '\0';
6869         if (NULL == had_version)
6870             *(strrchr(string, ';')) = '\0';
6871         if ((!had_directory) && (had_device == NULL))
6872             {
6873             if (NULL == (devdir = strrchr(string, ']')))
6874                 devdir = strrchr(string, '>');
6875             strcpy(string, devdir + 1);
6876             }
6877         /*
6878          * Be consistent with what the C RTL has already done to the rest of
6879          * the argv items and lowercase all of these names.
6880          */
6881         if (!decc_efs_case_preserve) {
6882             for (c = string; *c; ++c)
6883             if (isupper(*c))
6884                 *c = tolower(*c);
6885         }
6886         if (isunix) trim_unixpath(string,item,1);
6887         add_item(head, tail, string, count);
6888         ++expcount;
6889     }
6890     Safefree(vmsspec);
6891     if (sts != RMS$_NMF)
6892         {
6893         set_vaxc_errno(sts);
6894         switch (sts)
6895             {
6896             case RMS$_FNF: case RMS$_DNF:
6897                 set_errno(ENOENT); break;
6898             case RMS$_DIR:
6899                 set_errno(ENOTDIR); break;
6900             case RMS$_DEV:
6901                 set_errno(ENODEV); break;
6902             case RMS$_FNM: case RMS$_SYN:
6903                 set_errno(EINVAL); break;
6904             case RMS$_PRV:
6905                 set_errno(EACCES); break;
6906             default:
6907                 _ckvmssts_noperl(sts);
6908             }
6909         }
6910     if (expcount == 0)
6911         add_item(head, tail, item, count);
6912     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6913     _ckvmssts_noperl(lib$find_file_end(&context));
6914 }
6915
6916 static int child_st[2];/* Event Flag set when child process completes   */
6917
6918 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6919
6920 static unsigned long int exit_handler(int *status)
6921 {
6922 short iosb[4];
6923
6924     if (0 == child_st[0])
6925         {
6926 #ifdef ARGPROC_DEBUG
6927         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6928 #endif
6929         fflush(stdout);     /* Have to flush pipe for binary data to    */
6930                             /* terminate properly -- <tp@mccall.com>    */
6931         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6932         sys$dassgn(child_chan);
6933         fclose(stdout);
6934         sys$synch(0, child_st);
6935         }
6936     return(1);
6937 }
6938
6939 static void sig_child(int chan)
6940 {
6941 #ifdef ARGPROC_DEBUG
6942     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6943 #endif
6944     if (child_st[0] == 0)
6945         child_st[0] = 1;
6946 }
6947
6948 static struct exit_control_block exit_block =
6949     {
6950     0,
6951     exit_handler,
6952     1,
6953     &exit_block.exit_status,
6954     0
6955     };
6956
6957 static void
6958 pipe_and_fork(pTHX_ char **cmargv)
6959 {
6960     PerlIO *fp;
6961     struct dsc$descriptor_s *vmscmd;
6962     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6963     int sts, j, l, ismcr, quote, tquote = 0;
6964
6965     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6966     vms_execfree(vmscmd);
6967
6968     j = l = 0;
6969     p = subcmd;
6970     q = cmargv[0];
6971     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6972               && toupper(*(q+2)) == 'R' && !*(q+3);
6973
6974     while (q && l < MAX_DCL_LINE_LENGTH) {
6975         if (!*q) {
6976             if (j > 0 && quote) {
6977                 *p++ = '"';
6978                 l++;
6979             }
6980             q = cmargv[++j];
6981             if (q) {
6982                 if (ismcr && j > 1) quote = 1;
6983                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6984                 *p++ = ' ';
6985                 l++;
6986                 if (quote || tquote) {
6987                     *p++ = '"';
6988                     l++;
6989                 }
6990         }
6991         } else {
6992             if ((quote||tquote) && *q == '"') {
6993                 *p++ = '"';
6994                 l++;
6995         }
6996             *p++ = *q++;
6997             l++;
6998         }
6999     }
7000     *p = '\0';
7001
7002     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7003     if (fp == Nullfp) {
7004         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7005         }
7006 }
7007
7008 static int background_process(pTHX_ int argc, char **argv)
7009 {
7010 char command[MAX_DCL_SYMBOL + 1] = "$";
7011 $DESCRIPTOR(value, "");
7012 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7013 static $DESCRIPTOR(null, "NLA0:");
7014 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7015 char pidstring[80];
7016 $DESCRIPTOR(pidstr, "");
7017 int pid;
7018 unsigned long int flags = 17, one = 1, retsts;
7019 int len;
7020
7021     strcat(command, argv[0]);
7022     len = strlen(command);
7023     while (--argc && (len < MAX_DCL_SYMBOL))
7024         {
7025         strcat(command, " \"");
7026         strcat(command, *(++argv));
7027         strcat(command, "\"");
7028         len = strlen(command);
7029         }
7030     value.dsc$a_pointer = command;
7031     value.dsc$w_length = strlen(value.dsc$a_pointer);
7032     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7033     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7034     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7035         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7036     }
7037     else {
7038         _ckvmssts_noperl(retsts);
7039     }
7040 #ifdef ARGPROC_DEBUG
7041     PerlIO_printf(Perl_debug_log, "%s\n", command);
7042 #endif
7043     sprintf(pidstring, "%08X", pid);
7044     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7045     pidstr.dsc$a_pointer = pidstring;
7046     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7047     lib$set_symbol(&pidsymbol, &pidstr);
7048     return(SS$_NORMAL);
7049 }
7050 /*}}}*/
7051 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7052
7053
7054 /* OS-specific initialization at image activation (not thread startup) */
7055 /* Older VAXC header files lack these constants */
7056 #ifndef JPI$_RIGHTS_SIZE
7057 #  define JPI$_RIGHTS_SIZE 817
7058 #endif
7059 #ifndef KGB$M_SUBSYSTEM
7060 #  define KGB$M_SUBSYSTEM 0x8
7061 #endif
7062
7063 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7064
7065 /*{{{void vms_image_init(int *, char ***)*/
7066 void
7067 vms_image_init(int *argcp, char ***argvp)
7068 {
7069   char eqv[LNM$C_NAMLENGTH+1] = "";
7070   unsigned int len, tabct = 8, tabidx = 0;
7071   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7072   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7073   unsigned short int dummy, rlen;
7074   struct dsc$descriptor_s **tabvec;
7075 #if defined(PERL_IMPLICIT_CONTEXT)
7076   pTHX = NULL;
7077 #endif
7078   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7079                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7080                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7081                                  {          0,                0,    0,      0} };
7082
7083 #ifdef KILL_BY_SIGPRC
7084     Perl_csighandler_init();
7085 #endif
7086
7087   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7088   _ckvmssts_noperl(iosb[0]);
7089   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7090     if (iprv[i]) {           /* Running image installed with privs? */
7091       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7092       will_taint = TRUE;
7093       break;
7094     }
7095   }
7096   /* Rights identifiers might trigger tainting as well. */
7097   if (!will_taint && (rlen || rsz)) {
7098     while (rlen < rsz) {
7099       /* We didn't get all the identifiers on the first pass.  Allocate a
7100        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7101        * were needed to hold all identifiers at time of last call; we'll
7102        * allocate that many unsigned long ints), and go back and get 'em.
7103        * If it gave us less than it wanted to despite ample buffer space,
7104        * something's broken.  Is your system missing a system identifier?
7105        */
7106       if (rsz <= jpilist[1].buflen) {
7107          /* Perl_croak accvios when used this early in startup. */
7108          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7109                          rsz, (unsigned long) jpilist[1].buflen,
7110                          "Check your rights database for corruption.\n");
7111          exit(SS$_ABORT);
7112       }
7113       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7114       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7115       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7116       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7117       _ckvmssts_noperl(iosb[0]);
7118     }
7119     mask = jpilist[1].bufadr;
7120     /* Check attribute flags for each identifier (2nd longword); protected
7121      * subsystem identifiers trigger tainting.
7122      */
7123     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7124       if (mask[i] & KGB$M_SUBSYSTEM) {
7125         will_taint = TRUE;
7126         break;
7127       }
7128     }
7129     if (mask != rlst) Safefree(mask);
7130   }
7131
7132   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7133    * logical, some versions of the CRTL will add a phanthom /000000/
7134    * directory.  This needs to be removed.
7135    */
7136   if (decc_filename_unix_report) {
7137   char * zeros;
7138   int ulen;
7139     ulen = strlen(argvp[0][0]);
7140     if (ulen > 7) {
7141       zeros = strstr(argvp[0][0], "/000000/");
7142       if (zeros != NULL) {
7143         int mlen;
7144         mlen = ulen - (zeros - argvp[0][0]) - 7;
7145         memmove(zeros, &zeros[7], mlen);
7146         ulen = ulen - 7;
7147         argvp[0][0][ulen] = '\0';
7148       }
7149     }
7150     /* It also may have a trailing dot that needs to be removed otherwise
7151      * it will be converted to VMS mode incorrectly.
7152      */
7153     ulen--;
7154     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7155       argvp[0][0][ulen] = '\0';
7156   }
7157
7158   /* We need to use this hack to tell Perl it should run with tainting,
7159    * since its tainting flag may be part of the PL_curinterp struct, which
7160    * hasn't been allocated when vms_image_init() is called.
7161    */
7162   if (will_taint) {
7163     char **newargv, **oldargv;
7164     oldargv = *argvp;
7165     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7166     newargv[0] = oldargv[0];
7167     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7168     strcpy(newargv[1], "-T");
7169     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7170     (*argcp)++;
7171     newargv[*argcp] = NULL;
7172     /* We orphan the old argv, since we don't know where it's come from,
7173      * so we don't know how to free it.
7174      */
7175     *argvp = newargv;
7176   }
7177   else {  /* Did user explicitly request tainting? */
7178     int i;
7179     char *cp, **av = *argvp;
7180     for (i = 1; i < *argcp; i++) {
7181       if (*av[i] != '-') break;
7182       for (cp = av[i]+1; *cp; cp++) {
7183         if (*cp == 'T') { will_taint = 1; break; }
7184         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7185                   strchr("DFIiMmx",*cp)) break;
7186       }
7187       if (will_taint) break;
7188     }
7189   }
7190
7191   for (tabidx = 0;
7192        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7193        tabidx++) {
7194     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7195     else if (tabidx >= tabct) {
7196       tabct += 8;
7197       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7198     }
7199     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7200     tabvec[tabidx]->dsc$w_length  = 0;
7201     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7202     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7203     tabvec[tabidx]->dsc$a_pointer = NULL;
7204     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7205   }
7206   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7207
7208   getredirection(argcp,argvp);
7209 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7210   {
7211 # include <reentrancy.h>
7212   decc$set_reentrancy(C$C_MULTITHREAD);
7213   }
7214 #endif
7215   return;
7216 }
7217 /*}}}*/
7218
7219
7220 /* trim_unixpath()
7221  * Trim Unix-style prefix off filespec, so it looks like what a shell
7222  * glob expansion would return (i.e. from specified prefix on, not
7223  * full path).  Note that returned filespec is Unix-style, regardless
7224  * of whether input filespec was VMS-style or Unix-style.
7225  *
7226  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7227  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7228  * vector of options; at present, only bit 0 is used, and if set tells
7229  * trim unixpath to try the current default directory as a prefix when
7230  * presented with a possibly ambiguous ... wildcard.
7231  *
7232  * Returns !=0 on success, with trimmed filespec replacing contents of
7233  * fspec, and 0 on failure, with contents of fpsec unchanged.
7234  */
7235 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7236 int
7237 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7238 {
7239   char *unixified, *unixwild,
7240        *template, *base, *end, *cp1, *cp2;
7241   register int tmplen, reslen = 0, dirs = 0;
7242
7243   Newx(unixwild, VMS_MAXRSS, char);
7244   if (!wildspec || !fspec) return 0;
7245   template = unixwild;
7246   if (strpbrk(wildspec,"]>:") != NULL) {
7247     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7248         Safefree(unixwild);
7249         return 0;
7250     }
7251   }
7252   else {
7253     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7254     unixwild[VMS_MAXRSS-1] = 0;
7255   }
7256   Newx(unixified, VMS_MAXRSS, char);
7257   if (strpbrk(fspec,"]>:") != NULL) {
7258     if (do_tounixspec(fspec,unixified,0) == NULL) {
7259         Safefree(unixwild);
7260         Safefree(unixified);
7261         return 0;
7262     }
7263     else base = unixified;
7264     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7265      * check to see that final result fits into (isn't longer than) fspec */
7266     reslen = strlen(fspec);
7267   }
7268   else base = fspec;
7269
7270   /* No prefix or absolute path on wildcard, so nothing to remove */
7271   if (!*template || *template == '/') {
7272     Safefree(unixwild);
7273     if (base == fspec) {
7274         Safefree(unixified);
7275         return 1;
7276     }
7277     tmplen = strlen(unixified);
7278     if (tmplen > reslen) {
7279         Safefree(unixified);
7280         return 0;  /* not enough space */
7281     }
7282     /* Copy unixified resultant, including trailing NUL */
7283     memmove(fspec,unixified,tmplen+1);
7284     Safefree(unixified);
7285     return 1;
7286   }
7287
7288   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7289   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7290     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7291     for (cp1 = end ;cp1 >= base; cp1--)
7292       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7293         { cp1++; break; }
7294     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7295     Safefree(unixified);
7296     Safefree(unixwild);
7297     return 1;
7298   }
7299   else {
7300     char *tpl, *lcres;
7301     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7302     int ells = 1, totells, segdirs, match;
7303     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7304                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7305
7306     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7307     totells = ells;
7308     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7309     Newx(tpl, VMS_MAXRSS, char);
7310     if (ellipsis == template && opts & 1) {
7311       /* Template begins with an ellipsis.  Since we can't tell how many
7312        * directory names at the front of the resultant to keep for an
7313        * arbitrary starting point, we arbitrarily choose the current
7314        * default directory as a starting point.  If it's there as a prefix,
7315        * clip it off.  If not, fall through and act as if the leading
7316        * ellipsis weren't there (i.e. return shortest possible path that
7317        * could match template).
7318        */
7319       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7320           Safefree(tpl);
7321           Safefree(unixified);
7322           Safefree(unixwild);
7323           return 0;
7324       }
7325       if (!decc_efs_case_preserve) {
7326         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7327           if (_tolower(*cp1) != _tolower(*cp2)) break;
7328       }
7329       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7330       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7331       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7332         memmove(fspec,cp2+1,end - cp2);
7333         Safefree(unixified);
7334         Safefree(unixwild);
7335         Safefree(tpl);
7336         return 1;
7337       }
7338     }
7339     /* First off, back up over constant elements at end of path */
7340     if (dirs) {
7341       for (front = end ; front >= base; front--)
7342          if (*front == '/' && !dirs--) { front++; break; }
7343     }
7344     Newx(lcres, VMS_MAXRSS, char);
7345     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7346          cp1++,cp2++) {
7347             if (!decc_efs_case_preserve) {
7348                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7349             }
7350             else {
7351                 *cp2 = *cp1;
7352             }
7353     }
7354     if (cp1 != '\0') {
7355         Safefree(unixified);
7356         Safefree(unixwild);
7357         Safefree(lcres);
7358         Safefree(tpl);
7359         return 0;  /* Path too long. */
7360     }
7361     lcend = cp2;
7362     *cp2 = '\0';  /* Pick up with memcpy later */
7363     lcfront = lcres + (front - base);
7364     /* Now skip over each ellipsis and try to match the path in front of it. */
7365     while (ells--) {
7366       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7367         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7368             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7369       if (cp1 < template) break; /* template started with an ellipsis */
7370       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7371         ellipsis = cp1; continue;
7372       }
7373       wilddsc.dsc$a_pointer = tpl;
7374       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7375       nextell = cp1;
7376       for (segdirs = 0, cp2 = tpl;
7377            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7378            cp1++, cp2++) {
7379          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7380          else {
7381             if (!decc_efs_case_preserve) {
7382               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7383             }
7384             else {
7385               *cp2 = *cp1;  /* else preserve case for match */
7386             }
7387          }
7388          if (*cp2 == '/') segdirs++;
7389       }
7390       if (cp1 != ellipsis - 1) {
7391           Safefree(unixified);
7392           Safefree(unixwild);
7393           Safefree(lcres);
7394           Safefree(tpl);
7395           return 0; /* Path too long */
7396       }
7397       /* Back up at least as many dirs as in template before matching */
7398       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7399         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7400       for (match = 0; cp1 > lcres;) {
7401         resdsc.dsc$a_pointer = cp1;
7402         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7403           match++;
7404           if (match == 1) lcfront = cp1;
7405         }
7406         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7407       }
7408       if (!match) {
7409         Safefree(unixified);
7410         Safefree(unixwild);
7411         Safefree(lcres);
7412         Safefree(tpl);
7413         return 0;  /* Can't find prefix ??? */
7414       }
7415       if (match > 1 && opts & 1) {
7416         /* This ... wildcard could cover more than one set of dirs (i.e.
7417          * a set of similar dir names is repeated).  If the template
7418          * contains more than 1 ..., upstream elements could resolve the
7419          * ambiguity, but it's not worth a full backtracking setup here.
7420          * As a quick heuristic, clip off the current default directory
7421          * if it's present to find the trimmed spec, else use the
7422          * shortest string that this ... could cover.
7423          */
7424         char def[NAM$C_MAXRSS+1], *st;
7425
7426         if (getcwd(def, sizeof def,0) == NULL) {
7427             Safefree(unixified);
7428             Safefree(unixwild);
7429             Safefree(lcres);
7430             Safefree(tpl);
7431             return 0;
7432         }
7433         if (!decc_efs_case_preserve) {
7434           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7435             if (_tolower(*cp1) != _tolower(*cp2)) break;
7436         }
7437         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7438         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7439         if (*cp1 == '\0' && *cp2 == '/') {
7440           memmove(fspec,cp2+1,end - cp2);
7441           Safefree(lcres);
7442           Safefree(unixified);
7443           Safefree(unixwild);
7444           Safefree(tpl);
7445           return 1;
7446         }
7447         /* Nope -- stick with lcfront from above and keep going. */
7448       }
7449     }
7450     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7451     Safefree(unixified);
7452     Safefree(unixwild);
7453     Safefree(lcres);
7454     Safefree(tpl);
7455     return 1;
7456     ellipsis = nextell;
7457   }
7458
7459 }  /* end of trim_unixpath() */
7460 /*}}}*/
7461
7462
7463 /*
7464  *  VMS readdir() routines.
7465  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7466  *
7467  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7468  *  Minor modifications to original routines.
7469  */
7470
7471 /* readdir may have been redefined by reentr.h, so make sure we get
7472  * the local version for what we do here.
7473  */
7474 #ifdef readdir
7475 # undef readdir
7476 #endif
7477 #if !defined(PERL_IMPLICIT_CONTEXT)
7478 # define readdir Perl_readdir
7479 #else
7480 # define readdir(a) Perl_readdir(aTHX_ a)
7481 #endif
7482
7483     /* Number of elements in vms_versions array */
7484 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7485
7486 /*
7487  *  Open a directory, return a handle for later use.
7488  */
7489 /*{{{ DIR *opendir(char*name) */
7490 DIR *
7491 Perl_opendir(pTHX_ const char *name)
7492 {
7493     DIR *dd;
7494     char dir[NAM$C_MAXRSS+1];
7495     Stat_t sb;
7496
7497     if (do_tovmspath(name,dir,0) == NULL) {
7498       return NULL;
7499     }
7500     /* Check access before stat; otherwise stat does not
7501      * accurately report whether it's a directory.
7502      */
7503     if (!cando_by_name(S_IRUSR,0,dir)) {
7504       /* cando_by_name has already set errno */
7505       return NULL;
7506     }
7507     if (flex_stat(dir,&sb) == -1) return NULL;
7508     if (!S_ISDIR(sb.st_mode)) {
7509       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7510       return NULL;
7511     }
7512     /* Get memory for the handle, and the pattern. */
7513     Newx(dd,1,DIR);
7514     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7515
7516     /* Fill in the fields; mainly playing with the descriptor. */
7517     sprintf(dd->pattern, "%s*.*",dir);
7518     dd->context = 0;
7519     dd->count = 0;
7520     dd->vms_wantversions = 0;
7521     dd->pat.dsc$a_pointer = dd->pattern;
7522     dd->pat.dsc$w_length = strlen(dd->pattern);
7523     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7524     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7525 #if defined(USE_ITHREADS)
7526     Newx(dd->mutex,1,perl_mutex);
7527     MUTEX_INIT( (perl_mutex *) dd->mutex );
7528 #else
7529     dd->mutex = NULL;
7530 #endif
7531
7532     return dd;
7533 }  /* end of opendir() */
7534 /*}}}*/
7535
7536 /*
7537  *  Set the flag to indicate we want versions or not.
7538  */
7539 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7540 void
7541 vmsreaddirversions(DIR *dd, int flag)
7542 {
7543     dd->vms_wantversions = flag;
7544 }
7545 /*}}}*/
7546
7547 /*
7548  *  Free up an opened directory.
7549  */
7550 /*{{{ void closedir(DIR *dd)*/
7551 void
7552 Perl_closedir(DIR *dd)
7553 {
7554     int sts;
7555
7556     sts = lib$find_file_end(&dd->context);
7557     Safefree(dd->pattern);
7558 #if defined(USE_ITHREADS)
7559     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7560     Safefree(dd->mutex);
7561 #endif
7562     Safefree(dd);
7563 }
7564 /*}}}*/
7565
7566 /*
7567  *  Collect all the version numbers for the current file.
7568  */
7569 static void
7570 collectversions(pTHX_ DIR *dd)
7571 {
7572     struct dsc$descriptor_s     pat;
7573     struct dsc$descriptor_s     res;
7574     struct dirent *e;
7575     char *p, *text, buff[sizeof dd->entry.d_name];
7576     int i;
7577     unsigned long context, tmpsts;
7578
7579     /* Convenient shorthand. */
7580     e = &dd->entry;
7581
7582     /* Add the version wildcard, ignoring the "*.*" put on before */
7583     i = strlen(dd->pattern);
7584     Newx(text,i + e->d_namlen + 3,char);
7585     strcpy(text, dd->pattern);
7586     sprintf(&text[i - 3], "%s;*", e->d_name);
7587
7588     /* Set up the pattern descriptor. */
7589     pat.dsc$a_pointer = text;
7590     pat.dsc$w_length = i + e->d_namlen - 1;
7591     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7592     pat.dsc$b_class = DSC$K_CLASS_S;
7593
7594     /* Set up result descriptor. */
7595     res.dsc$a_pointer = buff;
7596     res.dsc$w_length = sizeof buff - 2;
7597     res.dsc$b_dtype = DSC$K_DTYPE_T;
7598     res.dsc$b_class = DSC$K_CLASS_S;
7599
7600     /* Read files, collecting versions. */
7601     for (context = 0, e->vms_verscount = 0;
7602          e->vms_verscount < VERSIZE(e);
7603          e->vms_verscount++) {
7604         tmpsts = lib$find_file(&pat, &res, &context);
7605         if (tmpsts == RMS$_NMF || context == 0) break;
7606         _ckvmssts(tmpsts);
7607         buff[sizeof buff - 1] = '\0';
7608         if ((p = strchr(buff, ';')))
7609             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7610         else
7611             e->vms_versions[e->vms_verscount] = -1;
7612     }
7613
7614     _ckvmssts(lib$find_file_end(&context));
7615     Safefree(text);
7616
7617 }  /* end of collectversions() */
7618
7619 /*
7620  *  Read the next entry from the directory.
7621  */
7622 /*{{{ struct dirent *readdir(DIR *dd)*/
7623 struct dirent *
7624 Perl_readdir(pTHX_ DIR *dd)
7625 {
7626     struct dsc$descriptor_s     res;
7627     char *p, buff[sizeof dd->entry.d_name];
7628     unsigned long int tmpsts;
7629
7630     /* Set up result descriptor, and get next file. */
7631     res.dsc$a_pointer = buff;
7632     res.dsc$w_length = sizeof buff - 2;
7633     res.dsc$b_dtype = DSC$K_DTYPE_T;
7634     res.dsc$b_class = DSC$K_CLASS_S;
7635     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7636     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7637     if (!(tmpsts & 1)) {
7638       set_vaxc_errno(tmpsts);
7639       switch (tmpsts) {
7640         case RMS$_PRV:
7641           set_errno(EACCES); break;
7642         case RMS$_DEV:
7643           set_errno(ENODEV); break;
7644         case RMS$_DIR:
7645           set_errno(ENOTDIR); break;
7646         case RMS$_FNF: case RMS$_DNF:
7647           set_errno(ENOENT); break;
7648         default:
7649           set_errno(EVMSERR);
7650       }
7651       return NULL;
7652     }
7653     dd->count++;
7654     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7655     if (!decc_efs_case_preserve) {
7656       buff[sizeof buff - 1] = '\0';
7657       for (p = buff; *p; p++) *p = _tolower(*p);
7658       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7659       *p = '\0';
7660     }
7661     else {
7662       /* we don't want to force to lowercase, just null terminate */
7663       buff[res.dsc$w_length] = '\0';
7664     }
7665     for (p = buff; *p; p++) *p = _tolower(*p);
7666     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7667     *p = '\0';
7668
7669     /* Skip any directory component and just copy the name. */
7670     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7671     else strcpy(dd->entry.d_name, buff);
7672
7673     /* Clobber the version. */
7674     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7675
7676     dd->entry.d_namlen = strlen(dd->entry.d_name);
7677     dd->entry.vms_verscount = 0;
7678     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7679     return &dd->entry;
7680
7681 }  /* end of readdir() */
7682 /*}}}*/
7683
7684 /*
7685  *  Read the next entry from the directory -- thread-safe version.
7686  */
7687 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7688 int
7689 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
7690 {
7691     int retval;
7692
7693     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7694
7695     entry = readdir(dd);
7696     *result = entry;
7697     retval = ( *result == NULL ? errno : 0 );
7698
7699     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7700
7701     return retval;
7702
7703 }  /* end of readdir_r() */
7704 /*}}}*/
7705
7706 /*
7707  *  Return something that can be used in a seekdir later.
7708  */
7709 /*{{{ long telldir(DIR *dd)*/
7710 long
7711 Perl_telldir(DIR *dd)
7712 {
7713     return dd->count;
7714 }
7715 /*}}}*/
7716
7717 /*
7718  *  Return to a spot where we used to be.  Brute force.
7719  */
7720 /*{{{ void seekdir(DIR *dd,long count)*/
7721 void
7722 Perl_seekdir(pTHX_ DIR *dd, long count)
7723 {
7724     int vms_wantversions;
7725
7726     /* If we haven't done anything yet... */
7727     if (dd->count == 0)
7728         return;
7729
7730     /* Remember some state, and clear it. */
7731     vms_wantversions = dd->vms_wantversions;
7732     dd->vms_wantversions = 0;
7733     _ckvmssts(lib$find_file_end(&dd->context));
7734     dd->context = 0;
7735
7736     /* The increment is in readdir(). */
7737     for (dd->count = 0; dd->count < count; )
7738         readdir(dd);
7739
7740     dd->vms_wantversions = vms_wantversions;
7741
7742 }  /* end of seekdir() */
7743 /*}}}*/
7744
7745 /* VMS subprocess management
7746  *
7747  * my_vfork() - just a vfork(), after setting a flag to record that
7748  * the current script is trying a Unix-style fork/exec.
7749  *
7750  * vms_do_aexec() and vms_do_exec() are called in response to the
7751  * perl 'exec' function.  If this follows a vfork call, then they
7752  * call out the regular perl routines in doio.c which do an
7753  * execvp (for those who really want to try this under VMS).
7754  * Otherwise, they do exactly what the perl docs say exec should
7755  * do - terminate the current script and invoke a new command
7756  * (See below for notes on command syntax.)
7757  *
7758  * do_aspawn() and do_spawn() implement the VMS side of the perl
7759  * 'system' function.
7760  *
7761  * Note on command arguments to perl 'exec' and 'system': When handled
7762  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7763  * are concatenated to form a DCL command string.  If the first arg
7764  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7765  * the command string is handed off to DCL directly.  Otherwise,
7766  * the first token of the command is taken as the filespec of an image
7767  * to run.  The filespec is expanded using a default type of '.EXE' and
7768  * the process defaults for device, directory, etc., and if found, the resultant
7769  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7770  * the command string as parameters.  This is perhaps a bit complicated,
7771  * but I hope it will form a happy medium between what VMS folks expect
7772  * from lib$spawn and what Unix folks expect from exec.
7773  */
7774
7775 static int vfork_called;
7776
7777 /*{{{int my_vfork()*/
7778 int
7779 my_vfork()
7780 {
7781   vfork_called++;
7782   return vfork();
7783 }
7784 /*}}}*/
7785
7786
7787 static void
7788 vms_execfree(struct dsc$descriptor_s *vmscmd)
7789 {
7790   if (vmscmd) {
7791       if (vmscmd->dsc$a_pointer) {
7792           Safefree(vmscmd->dsc$a_pointer);
7793       }
7794       Safefree(vmscmd);
7795   }
7796 }
7797
7798 static char *
7799 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7800 {
7801   char *junk, *tmps = Nullch;
7802   register size_t cmdlen = 0;
7803   size_t rlen;
7804   register SV **idx;
7805   STRLEN n_a;
7806
7807   idx = mark;
7808   if (really) {
7809     tmps = SvPV(really,rlen);
7810     if (*tmps) {
7811       cmdlen += rlen + 1;
7812       idx++;
7813     }
7814   }
7815
7816   for (idx++; idx <= sp; idx++) {
7817     if (*idx) {
7818       junk = SvPVx(*idx,rlen);
7819       cmdlen += rlen ? rlen + 1 : 0;
7820     }
7821   }
7822   Newx(PL_Cmd,cmdlen+1,char);
7823
7824   if (tmps && *tmps) {
7825     strcpy(PL_Cmd,tmps);
7826     mark++;
7827   }
7828   else *PL_Cmd = '\0';
7829   while (++mark <= sp) {
7830     if (*mark) {
7831       char *s = SvPVx(*mark,n_a);
7832       if (!*s) continue;
7833       if (*PL_Cmd) strcat(PL_Cmd," ");
7834       strcat(PL_Cmd,s);
7835     }
7836   }
7837   return PL_Cmd;
7838
7839 }  /* end of setup_argstr() */
7840
7841
7842 static unsigned long int
7843 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7844                    struct dsc$descriptor_s **pvmscmd)
7845 {
7846   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7847   char image_name[NAM$C_MAXRSS+1];
7848   char image_argv[NAM$C_MAXRSS+1];
7849   $DESCRIPTOR(defdsc,".EXE");
7850   $DESCRIPTOR(defdsc2,".");
7851   $DESCRIPTOR(resdsc,resspec);
7852   struct dsc$descriptor_s *vmscmd;
7853   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7854   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7855   register char *s, *rest, *cp, *wordbreak;
7856   char * cmd;
7857   int cmdlen;
7858   register int isdcl;
7859
7860   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7861
7862   /* Make a copy for modification */
7863   cmdlen = strlen(incmd);
7864   Newx(cmd, cmdlen+1, char);
7865   strncpy(cmd, incmd, cmdlen);
7866   cmd[cmdlen] = 0;
7867   image_name[0] = 0;
7868   image_argv[0] = 0;
7869
7870   vmscmd->dsc$a_pointer = NULL;
7871   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7872   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7873   vmscmd->dsc$w_length = 0;
7874   if (pvmscmd) *pvmscmd = vmscmd;
7875
7876   if (suggest_quote) *suggest_quote = 0;
7877
7878   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7879     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7880     Safefree(cmd);
7881   }
7882
7883   s = cmd;
7884
7885   while (*s && isspace(*s)) s++;
7886
7887   if (*s == '@' || *s == '$') {
7888     vmsspec[0] = *s;  rest = s + 1;
7889     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7890   }
7891   else { cp = vmsspec; rest = s; }
7892   if (*rest == '.' || *rest == '/') {
7893     char *cp2;
7894     for (cp2 = resspec;
7895          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7896          rest++, cp2++) *cp2 = *rest;
7897     *cp2 = '\0';
7898     if (do_tovmsspec(resspec,cp,0)) {
7899       s = vmsspec;
7900       if (*rest) {
7901         for (cp2 = vmsspec + strlen(vmsspec);
7902              *rest && cp2 - vmsspec < sizeof vmsspec;
7903              rest++, cp2++) *cp2 = *rest;
7904         *cp2 = '\0';
7905       }
7906     }
7907   }
7908   /* Intuit whether verb (first word of cmd) is a DCL command:
7909    *   - if first nonspace char is '@', it's a DCL indirection
7910    * otherwise
7911    *   - if verb contains a filespec separator, it's not a DCL command
7912    *   - if it doesn't, caller tells us whether to default to a DCL
7913    *     command, or to a local image unless told it's DCL (by leading '$')
7914    */
7915   if (*s == '@') {
7916       isdcl = 1;
7917       if (suggest_quote) *suggest_quote = 1;
7918   } else {
7919     register char *filespec = strpbrk(s,":<[.;");
7920     rest = wordbreak = strpbrk(s," \"\t/");
7921     if (!wordbreak) wordbreak = s + strlen(s);
7922     if (*s == '$') check_img = 0;
7923     if (filespec && (filespec < wordbreak)) isdcl = 0;
7924     else isdcl = !check_img;
7925   }
7926
7927   if (!isdcl) {
7928     imgdsc.dsc$a_pointer = s;
7929     imgdsc.dsc$w_length = wordbreak - s;
7930     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7931     if (!(retsts&1)) {
7932         _ckvmssts(lib$find_file_end(&cxt));
7933         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7934       if (!(retsts & 1) && *s == '$') {
7935         _ckvmssts(lib$find_file_end(&cxt));
7936         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7937         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7938         if (!(retsts&1)) {
7939           _ckvmssts(lib$find_file_end(&cxt));
7940           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7941         }
7942       }
7943     }
7944     _ckvmssts(lib$find_file_end(&cxt));
7945
7946     if (retsts & 1) {
7947       FILE *fp;
7948       s = resspec;
7949       while (*s && !isspace(*s)) s++;
7950       *s = '\0';
7951
7952       /* check that it's really not DCL with no file extension */
7953       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7954       if (fp) {
7955         char b[256] = {0,0,0,0};
7956         read(fileno(fp), b, 256);
7957         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7958         if (isdcl) {
7959           int shebang_len;
7960
7961           /* Check for script */
7962           shebang_len = 0;
7963           if ((b[0] == '#') && (b[1] == '!'))
7964              shebang_len = 2;
7965 #ifdef ALTERNATE_SHEBANG
7966           else {
7967             shebang_len = strlen(ALTERNATE_SHEBANG);
7968             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7969               char * perlstr;
7970                 perlstr = strstr("perl",b);
7971                 if (perlstr == NULL)
7972                   shebang_len = 0;
7973             }
7974             else
7975               shebang_len = 0;
7976           }
7977 #endif
7978
7979           if (shebang_len > 0) {
7980           int i;
7981           int j;
7982           char tmpspec[NAM$C_MAXRSS + 1];
7983
7984             i = shebang_len;
7985              /* Image is following after white space */
7986             /*--------------------------------------*/
7987             while (isprint(b[i]) && isspace(b[i]))
7988                 i++;
7989
7990             j = 0;
7991             while (isprint(b[i]) && !isspace(b[i])) {
7992                 tmpspec[j++] = b[i++];
7993                 if (j >= NAM$C_MAXRSS)
7994                    break;
7995             }
7996             tmpspec[j] = '\0';
7997
7998              /* There may be some default parameters to the image */
7999             /*---------------------------------------------------*/
8000             j = 0;
8001             while (isprint(b[i])) {
8002                 image_argv[j++] = b[i++];
8003                 if (j >= NAM$C_MAXRSS)
8004                    break;
8005             }
8006             while ((j > 0) && !isprint(image_argv[j-1]))
8007                 j--;
8008             image_argv[j] = 0;
8009
8010             /* It will need to be converted to VMS format and validated */
8011             if (tmpspec[0] != '\0') {
8012               char * iname;
8013
8014                /* Try to find the exact program requested to be run */
8015               /*---------------------------------------------------*/
8016               iname = do_rmsexpand
8017                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8018               if (iname != NULL) {
8019                 if (cando_by_name(S_IXUSR,0,image_name)) {
8020                   /* MCR prefix needed */
8021                   isdcl = 0;
8022                 }
8023                 else {
8024                    /* Try again with a null type */
8025                   /*----------------------------*/
8026                   iname = do_rmsexpand
8027                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8028                   if (iname != NULL) {
8029                     if (cando_by_name(S_IXUSR,0,image_name)) {
8030                       /* MCR prefix needed */
8031                       isdcl = 0;
8032                     }
8033                   }
8034                 }
8035
8036                  /* Did we find the image to run the script? */
8037                 /*------------------------------------------*/
8038                 if (isdcl) {
8039                   char *tchr;
8040
8041                    /* Assume DCL or foreign command exists */
8042                   /*--------------------------------------*/
8043                   tchr = strrchr(tmpspec, '/');
8044                   if (tchr != NULL) {
8045                     tchr++;
8046                   }
8047                   else {
8048                     tchr = tmpspec;
8049                   }
8050                   strcpy(image_name, tchr);
8051                 }
8052               }
8053             }
8054           }
8055         }
8056         fclose(fp);
8057       }
8058       if (check_img && isdcl) return RMS$_FNF;
8059
8060       if (cando_by_name(S_IXUSR,0,resspec)) {
8061         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8062         if (!isdcl) {
8063             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8064             if (image_name[0] != 0) {
8065                 strcat(vmscmd->dsc$a_pointer, image_name);
8066                 strcat(vmscmd->dsc$a_pointer, " ");
8067             }
8068         } else if (image_name[0] != 0) {
8069             strcpy(vmscmd->dsc$a_pointer, image_name);
8070             strcat(vmscmd->dsc$a_pointer, " ");
8071         } else {
8072             strcpy(vmscmd->dsc$a_pointer,"@");
8073         }
8074         if (suggest_quote) *suggest_quote = 1;
8075
8076         /* If there is an image name, use original command */
8077         if (image_name[0] == 0)
8078             strcat(vmscmd->dsc$a_pointer,resspec);
8079         else {
8080             rest = cmd;
8081             while (*rest && isspace(*rest)) rest++;
8082         }
8083
8084         if (image_argv[0] != 0) {
8085           strcat(vmscmd->dsc$a_pointer,image_argv);
8086           strcat(vmscmd->dsc$a_pointer, " ");
8087         }
8088         if (rest) {
8089            int rest_len;
8090            int vmscmd_len;
8091
8092            rest_len = strlen(rest);
8093            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8094            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8095               strcat(vmscmd->dsc$a_pointer,rest);
8096            else
8097              retsts = CLI$_BUFOVF;
8098         }
8099         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8100         Safefree(cmd);
8101         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8102       }
8103       else retsts = RMS$_PRV;
8104     }
8105   }
8106   /* It's either a DCL command or we couldn't find a suitable image */
8107   vmscmd->dsc$w_length = strlen(cmd);
8108 /*  if (cmd == PL_Cmd) {
8109       vmscmd->dsc$a_pointer = PL_Cmd;
8110       if (suggest_quote) *suggest_quote = 1;
8111   }
8112   else  */
8113       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8114
8115   Safefree(cmd);
8116
8117   /* check if it's a symbol (for quoting purposes) */
8118   if (suggest_quote && !*suggest_quote) {
8119     int iss;
8120     char equiv[LNM$C_NAMLENGTH];
8121     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8122     eqvdsc.dsc$a_pointer = equiv;
8123
8124     iss = lib$get_symbol(vmscmd,&eqvdsc);
8125     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8126   }
8127   if (!(retsts & 1)) {
8128     /* just hand off status values likely to be due to user error */
8129     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8130         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8131        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8132     else { _ckvmssts(retsts); }
8133   }
8134
8135   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8136
8137 }  /* end of setup_cmddsc() */
8138
8139
8140 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8141 bool
8142 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8143 {
8144   if (sp > mark) {
8145     if (vfork_called) {           /* this follows a vfork - act Unixish */
8146       vfork_called--;
8147       if (vfork_called < 0) {
8148         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8149         vfork_called = 0;
8150       }
8151       else return do_aexec(really,mark,sp);
8152     }
8153                                            /* no vfork - act VMSish */
8154     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8155
8156   }
8157
8158   return FALSE;
8159 }  /* end of vms_do_aexec() */
8160 /*}}}*/
8161
8162 /* {{{bool vms_do_exec(char *cmd) */
8163 bool
8164 Perl_vms_do_exec(pTHX_ const char *cmd)
8165 {
8166   struct dsc$descriptor_s *vmscmd;
8167
8168   if (vfork_called) {             /* this follows a vfork - act Unixish */
8169     vfork_called--;
8170     if (vfork_called < 0) {
8171       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8172       vfork_called = 0;
8173     }
8174     else return do_exec(cmd);
8175   }
8176
8177   {                               /* no vfork - act VMSish */
8178     unsigned long int retsts;
8179
8180     TAINT_ENV();
8181     TAINT_PROPER("exec");
8182     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8183       retsts = lib$do_command(vmscmd);
8184
8185     switch (retsts) {
8186       case RMS$_FNF: case RMS$_DNF:
8187         set_errno(ENOENT); break;
8188       case RMS$_DIR:
8189         set_errno(ENOTDIR); break;
8190       case RMS$_DEV:
8191         set_errno(ENODEV); break;
8192       case RMS$_PRV:
8193         set_errno(EACCES); break;
8194       case RMS$_SYN:
8195         set_errno(EINVAL); break;
8196       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8197         set_errno(E2BIG); break;
8198       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8199         _ckvmssts(retsts); /* fall through */
8200       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8201         set_errno(EVMSERR);
8202     }
8203     set_vaxc_errno(retsts);
8204     if (ckWARN(WARN_EXEC)) {
8205       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8206              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8207     }
8208     vms_execfree(vmscmd);
8209   }
8210
8211   return FALSE;
8212
8213 }  /* end of vms_do_exec() */
8214 /*}}}*/
8215
8216 unsigned long int Perl_do_spawn(pTHX_ const char *);
8217
8218 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8219 unsigned long int
8220 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8221 {
8222   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8223
8224   return SS$_ABORT;
8225 }  /* end of do_aspawn() */
8226 /*}}}*/
8227
8228 /* {{{unsigned long int do_spawn(char *cmd) */
8229 unsigned long int
8230 Perl_do_spawn(pTHX_ const char *cmd)
8231 {
8232   unsigned long int sts, substs;
8233
8234   TAINT_ENV();
8235   TAINT_PROPER("spawn");
8236   if (!cmd || !*cmd) {
8237     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8238     if (!(sts & 1)) {
8239       switch (sts) {
8240         case RMS$_FNF:  case RMS$_DNF:
8241           set_errno(ENOENT); break;
8242         case RMS$_DIR:
8243           set_errno(ENOTDIR); break;
8244         case RMS$_DEV:
8245           set_errno(ENODEV); break;
8246         case RMS$_PRV:
8247           set_errno(EACCES); break;
8248         case RMS$_SYN:
8249           set_errno(EINVAL); break;
8250         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8251           set_errno(E2BIG); break;
8252         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8253           _ckvmssts(sts); /* fall through */
8254         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8255           set_errno(EVMSERR);
8256       }
8257       set_vaxc_errno(sts);
8258       if (ckWARN(WARN_EXEC)) {
8259         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8260                     Strerror(errno));
8261       }
8262     }
8263     sts = substs;
8264   }
8265   else {
8266     PerlIO * fp;
8267     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8268     if (fp != NULL)
8269       my_pclose(fp);
8270   }
8271   return sts;
8272 }  /* end of do_spawn() */
8273 /*}}}*/
8274
8275
8276 static unsigned int *sockflags, sockflagsize;
8277
8278 /*
8279  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8280  * routines found in some versions of the CRTL can't deal with sockets.
8281  * We don't shim the other file open routines since a socket isn't
8282  * likely to be opened by a name.
8283  */
8284 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8285 FILE *my_fdopen(int fd, const char *mode)
8286 {
8287   FILE *fp = fdopen(fd, mode);
8288
8289   if (fp) {
8290     unsigned int fdoff = fd / sizeof(unsigned int);
8291     Stat_t sbuf; /* native stat; we don't need flex_stat */
8292     if (!sockflagsize || fdoff > sockflagsize) {
8293       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8294       else           Newx  (sockflags,fdoff+2,unsigned int);
8295       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8296       sockflagsize = fdoff + 2;
8297     }
8298     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8299       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8300   }
8301   return fp;
8302
8303 }
8304 /*}}}*/
8305
8306
8307 /*
8308  * Clear the corresponding bit when the (possibly) socket stream is closed.
8309  * There still a small hole: we miss an implicit close which might occur
8310  * via freopen().  >> Todo
8311  */
8312 /*{{{ int my_fclose(FILE *fp)*/
8313 int my_fclose(FILE *fp) {
8314   if (fp) {
8315     unsigned int fd = fileno(fp);
8316     unsigned int fdoff = fd / sizeof(unsigned int);
8317
8318     if (sockflagsize && fdoff <= sockflagsize)
8319       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8320   }
8321   return fclose(fp);
8322 }
8323 /*}}}*/
8324
8325
8326 /*
8327  * A simple fwrite replacement which outputs itmsz*nitm chars without
8328  * introducing record boundaries every itmsz chars.
8329  * We are using fputs, which depends on a terminating null.  We may
8330  * well be writing binary data, so we need to accommodate not only
8331  * data with nulls sprinkled in the middle but also data with no null
8332  * byte at the end.
8333  */
8334 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8335 int
8336 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8337 {
8338   register char *cp, *end, *cpd, *data;
8339   register unsigned int fd = fileno(dest);
8340   register unsigned int fdoff = fd / sizeof(unsigned int);
8341   int retval;
8342   int bufsize = itmsz * nitm + 1;
8343
8344   if (fdoff < sockflagsize &&
8345       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8346     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8347     return nitm;
8348   }
8349
8350   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8351   memcpy( data, src, itmsz*nitm );
8352   data[itmsz*nitm] = '\0';
8353
8354   end = data + itmsz * nitm;
8355   retval = (int) nitm; /* on success return # items written */
8356
8357   cpd = data;
8358   while (cpd <= end) {
8359     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8360     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8361     if (cp < end)
8362       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8363     cpd = cp + 1;
8364   }
8365
8366   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8367   return retval;
8368
8369 }  /* end of my_fwrite() */
8370 /*}}}*/
8371
8372 /*{{{ int my_flush(FILE *fp)*/
8373 int
8374 Perl_my_flush(pTHX_ FILE *fp)
8375 {
8376     int res;
8377     if ((res = fflush(fp)) == 0 && fp) {
8378 #ifdef VMS_DO_SOCKETS
8379         Stat_t s;
8380         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8381 #endif
8382             res = fsync(fileno(fp));
8383     }
8384 /*
8385  * If the flush succeeded but set end-of-file, we need to clear
8386  * the error because our caller may check ferror().  BTW, this
8387  * probably means we just flushed an empty file.
8388  */
8389     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8390
8391     return res;
8392 }
8393 /*}}}*/
8394
8395 /*
8396  * Here are replacements for the following Unix routines in the VMS environment:
8397  *      getpwuid    Get information for a particular UIC or UID
8398  *      getpwnam    Get information for a named user
8399  *      getpwent    Get information for each user in the rights database
8400  *      setpwent    Reset search to the start of the rights database
8401  *      endpwent    Finish searching for users in the rights database
8402  *
8403  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8404  * (defined in pwd.h), which contains the following fields:-
8405  *      struct passwd {
8406  *              char        *pw_name;    Username (in lower case)
8407  *              char        *pw_passwd;  Hashed password
8408  *              unsigned int pw_uid;     UIC
8409  *              unsigned int pw_gid;     UIC group  number
8410  *              char        *pw_unixdir; Default device/directory (VMS-style)
8411  *              char        *pw_gecos;   Owner name
8412  *              char        *pw_dir;     Default device/directory (Unix-style)
8413  *              char        *pw_shell;   Default CLI name (eg. DCL)
8414  *      };
8415  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8416  *
8417  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8418  * not the UIC member number (eg. what's returned by getuid()),
8419  * getpwuid() can accept either as input (if uid is specified, the caller's
8420  * UIC group is used), though it won't recognise gid=0.
8421  *
8422  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8423  * information about other users in your group or in other groups, respectively.
8424  * If the required privilege is not available, then these routines fill only
8425  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8426  * string).
8427  *
8428  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8429  */
8430
8431 /* sizes of various UAF record fields */
8432 #define UAI$S_USERNAME 12
8433 #define UAI$S_IDENT    31
8434 #define UAI$S_OWNER    31
8435 #define UAI$S_DEFDEV   31
8436 #define UAI$S_DEFDIR   63
8437 #define UAI$S_DEFCLI   31
8438 #define UAI$S_PWD       8
8439
8440 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8441                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8442                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8443
8444 static char __empty[]= "";
8445 static struct passwd __passwd_empty=
8446     {(char *) __empty, (char *) __empty, 0, 0,
8447      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8448 static int contxt= 0;
8449 static struct passwd __pwdcache;
8450 static char __pw_namecache[UAI$S_IDENT+1];
8451
8452 /*
8453  * This routine does most of the work extracting the user information.
8454  */
8455 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8456 {
8457     static struct {
8458         unsigned char length;
8459         char pw_gecos[UAI$S_OWNER+1];
8460     } owner;
8461     static union uicdef uic;
8462     static struct {
8463         unsigned char length;
8464         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8465     } defdev;
8466     static struct {
8467         unsigned char length;
8468         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8469     } defdir;
8470     static struct {
8471         unsigned char length;
8472         char pw_shell[UAI$S_DEFCLI+1];
8473     } defcli;
8474     static char pw_passwd[UAI$S_PWD+1];
8475
8476     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8477     struct dsc$descriptor_s name_desc;
8478     unsigned long int sts;
8479
8480     static struct itmlst_3 itmlst[]= {
8481         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8482         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8483         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8484         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8485         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8486         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8487         {0,                0,           NULL,    NULL}};
8488
8489     name_desc.dsc$w_length=  strlen(name);
8490     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8491     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8492     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8493
8494 /*  Note that sys$getuai returns many fields as counted strings. */
8495     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8496     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8497       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8498     }
8499     else { _ckvmssts(sts); }
8500     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8501
8502     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8503     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8504     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8505     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8506     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8507     owner.pw_gecos[lowner]=            '\0';
8508     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8509     defcli.pw_shell[ldefcli]=          '\0';
8510     if (valid_uic(uic)) {
8511         pwd->pw_uid= uic.uic$l_uic;
8512         pwd->pw_gid= uic.uic$v_group;
8513     }
8514     else
8515       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8516     pwd->pw_passwd=  pw_passwd;
8517     pwd->pw_gecos=   owner.pw_gecos;
8518     pwd->pw_dir=     defdev.pw_dir;
8519     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8520     pwd->pw_shell=   defcli.pw_shell;
8521     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8522         int ldir;
8523         ldir= strlen(pwd->pw_unixdir) - 1;
8524         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8525     }
8526     else
8527         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8528     if (!decc_efs_case_preserve)
8529         __mystrtolower(pwd->pw_unixdir);
8530     return 1;
8531 }
8532
8533 /*
8534  * Get information for a named user.
8535 */
8536 /*{{{struct passwd *getpwnam(char *name)*/
8537 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8538 {
8539     struct dsc$descriptor_s name_desc;
8540     union uicdef uic;
8541     unsigned long int status, sts;
8542
8543     __pwdcache = __passwd_empty;
8544     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8545       /* We still may be able to determine pw_uid and pw_gid */
8546       name_desc.dsc$w_length=  strlen(name);
8547       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8548       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8549       name_desc.dsc$a_pointer= (char *) name;
8550       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8551         __pwdcache.pw_uid= uic.uic$l_uic;
8552         __pwdcache.pw_gid= uic.uic$v_group;
8553       }
8554       else {
8555         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8556           set_vaxc_errno(sts);
8557           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8558           return NULL;
8559         }
8560         else { _ckvmssts(sts); }
8561       }
8562     }
8563     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8564     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8565     __pwdcache.pw_name= __pw_namecache;
8566     return &__pwdcache;
8567 }  /* end of my_getpwnam() */
8568 /*}}}*/
8569
8570 /*
8571  * Get information for a particular UIC or UID.
8572  * Called by my_getpwent with uid=-1 to list all users.
8573 */
8574 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8575 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8576 {
8577     const $DESCRIPTOR(name_desc,__pw_namecache);
8578     unsigned short lname;
8579     union uicdef uic;
8580     unsigned long int status;
8581
8582     if (uid == (unsigned int) -1) {
8583       do {
8584         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8585         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8586           set_vaxc_errno(status);
8587           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8588           my_endpwent();
8589           return NULL;
8590         }
8591         else { _ckvmssts(status); }
8592       } while (!valid_uic (uic));
8593     }
8594     else {
8595       uic.uic$l_uic= uid;
8596       if (!uic.uic$v_group)
8597         uic.uic$v_group= PerlProc_getgid();
8598       if (valid_uic(uic))
8599         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8600       else status = SS$_IVIDENT;
8601       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8602           status == RMS$_PRV) {
8603         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8604         return NULL;
8605       }
8606       else { _ckvmssts(status); }
8607     }
8608     __pw_namecache[lname]= '\0';
8609     __mystrtolower(__pw_namecache);
8610
8611     __pwdcache = __passwd_empty;
8612     __pwdcache.pw_name = __pw_namecache;
8613
8614 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8615     The identifier's value is usually the UIC, but it doesn't have to be,
8616     so if we can, we let fillpasswd update this. */
8617     __pwdcache.pw_uid =  uic.uic$l_uic;
8618     __pwdcache.pw_gid =  uic.uic$v_group;
8619
8620     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8621     return &__pwdcache;
8622
8623 }  /* end of my_getpwuid() */
8624 /*}}}*/
8625
8626 /*
8627  * Get information for next user.
8628 */
8629 /*{{{struct passwd *my_getpwent()*/
8630 struct passwd *Perl_my_getpwent(pTHX)
8631 {
8632     return (my_getpwuid((unsigned int) -1));
8633 }
8634 /*}}}*/
8635
8636 /*
8637  * Finish searching rights database for users.
8638 */
8639 /*{{{void my_endpwent()*/
8640 void Perl_my_endpwent(pTHX)
8641 {
8642     if (contxt) {
8643       _ckvmssts(sys$finish_rdb(&contxt));
8644       contxt= 0;
8645     }
8646 }
8647 /*}}}*/
8648
8649 #ifdef HOMEGROWN_POSIX_SIGNALS
8650   /* Signal handling routines, pulled into the core from POSIX.xs.
8651    *
8652    * We need these for threads, so they've been rolled into the core,
8653    * rather than left in POSIX.xs.
8654    *
8655    * (DRS, Oct 23, 1997)
8656    */
8657
8658   /* sigset_t is atomic under VMS, so these routines are easy */
8659 /*{{{int my_sigemptyset(sigset_t *) */
8660 int my_sigemptyset(sigset_t *set) {
8661     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8662     *set = 0; return 0;
8663 }
8664 /*}}}*/
8665
8666
8667 /*{{{int my_sigfillset(sigset_t *)*/
8668 int my_sigfillset(sigset_t *set) {
8669     int i;
8670     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8671     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8672     return 0;
8673 }
8674 /*}}}*/
8675
8676
8677 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8678 int my_sigaddset(sigset_t *set, int sig) {
8679     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8680     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8681     *set |= (1 << (sig - 1));
8682     return 0;
8683 }
8684 /*}}}*/
8685
8686
8687 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8688 int my_sigdelset(sigset_t *set, int sig) {
8689     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8690     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8691     *set &= ~(1 << (sig - 1));
8692     return 0;
8693 }
8694 /*}}}*/
8695
8696
8697 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8698 int my_sigismember(sigset_t *set, int sig) {
8699     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8700     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8701     return *set & (1 << (sig - 1));
8702 }
8703 /*}}}*/
8704
8705
8706 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8707 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8708     sigset_t tempmask;
8709
8710     /* If set and oset are both null, then things are badly wrong. Bail out. */
8711     if ((oset == NULL) && (set == NULL)) {
8712       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8713       return -1;
8714     }
8715
8716     /* If set's null, then we're just handling a fetch. */
8717     if (set == NULL) {
8718         tempmask = sigblock(0);
8719     }
8720     else {
8721       switch (how) {
8722       case SIG_SETMASK:
8723         tempmask = sigsetmask(*set);
8724         break;
8725       case SIG_BLOCK:
8726         tempmask = sigblock(*set);
8727         break;
8728       case SIG_UNBLOCK:
8729         tempmask = sigblock(0);
8730         sigsetmask(*oset & ~tempmask);
8731         break;
8732       default:
8733         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8734         return -1;
8735       }
8736     }
8737
8738     /* Did they pass us an oset? If so, stick our holding mask into it */
8739     if (oset)
8740       *oset = tempmask;
8741
8742     return 0;
8743 }
8744 /*}}}*/
8745 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8746
8747
8748 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8749  * my_utime(), and flex_stat(), all of which operate on UTC unless
8750  * VMSISH_TIMES is true.
8751  */
8752 /* method used to handle UTC conversions:
8753  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8754  */
8755 static int gmtime_emulation_type;
8756 /* number of secs to add to UTC POSIX-style time to get local time */
8757 static long int utc_offset_secs;
8758
8759 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8760  * in vmsish.h.  #undef them here so we can call the CRTL routines
8761  * directly.
8762  */
8763 #undef gmtime
8764 #undef localtime
8765 #undef time
8766
8767
8768 /*
8769  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8770  * qualifier with the extern prefix pragma.  This provisional
8771  * hack circumvents this prefix pragma problem in previous
8772  * precompilers.
8773  */
8774 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8775 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8776 #    pragma __extern_prefix save
8777 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8778 #    define gmtime decc$__utctz_gmtime
8779 #    define localtime decc$__utctz_localtime
8780 #    define time decc$__utc_time
8781 #    pragma __extern_prefix restore
8782
8783      struct tm *gmtime(), *localtime();
8784
8785 #  endif
8786 #endif
8787
8788
8789 static time_t toutc_dst(time_t loc) {
8790   struct tm *rsltmp;
8791
8792   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8793   loc -= utc_offset_secs;
8794   if (rsltmp->tm_isdst) loc -= 3600;
8795   return loc;
8796 }
8797 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8798        ((gmtime_emulation_type || my_time(NULL)), \
8799        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8800        ((secs) - utc_offset_secs))))
8801
8802 static time_t toloc_dst(time_t utc) {
8803   struct tm *rsltmp;
8804
8805   utc += utc_offset_secs;
8806   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8807   if (rsltmp->tm_isdst) utc += 3600;
8808   return utc;
8809 }
8810 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8811        ((gmtime_emulation_type || my_time(NULL)), \
8812        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8813        ((secs) + utc_offset_secs))))
8814
8815 #ifndef RTL_USES_UTC
8816 /*
8817
8818     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8819         DST starts on 1st sun of april      at 02:00  std time
8820             ends on last sun of october     at 02:00  dst time
8821     see the UCX management command reference, SET CONFIG TIMEZONE
8822     for formatting info.
8823
8824     No, it's not as general as it should be, but then again, NOTHING
8825     will handle UK times in a sensible way.
8826 */
8827
8828
8829 /*
8830     parse the DST start/end info:
8831     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8832 */
8833
8834 static char *
8835 tz_parse_startend(char *s, struct tm *w, int *past)
8836 {
8837     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8838     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8839     time_t g;
8840
8841     if (!s)    return 0;
8842     if (!w) return 0;
8843     if (!past) return 0;
8844
8845     ly = 0;
8846     if (w->tm_year % 4        == 0) ly = 1;
8847     if (w->tm_year % 100      == 0) ly = 0;
8848     if (w->tm_year+1900 % 400 == 0) ly = 1;
8849     if (ly) dinm[1]++;
8850
8851     dozjd = isdigit(*s);
8852     if (*s == 'J' || *s == 'j' || dozjd) {
8853         if (!dozjd && !isdigit(*++s)) return 0;
8854         d = *s++ - '0';
8855         if (isdigit(*s)) {
8856             d = d*10 + *s++ - '0';
8857             if (isdigit(*s)) {
8858                 d = d*10 + *s++ - '0';
8859             }
8860         }
8861         if (d == 0) return 0;
8862         if (d > 366) return 0;
8863         d--;
8864         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8865         g = d * 86400;
8866         dozjd = 1;
8867     } else if (*s == 'M' || *s == 'm') {
8868         if (!isdigit(*++s)) return 0;
8869         m = *s++ - '0';
8870         if (isdigit(*s)) m = 10*m + *s++ - '0';
8871         if (*s != '.') return 0;
8872         if (!isdigit(*++s)) return 0;
8873         n = *s++ - '0';
8874         if (n < 1 || n > 5) return 0;
8875         if (*s != '.') return 0;
8876         if (!isdigit(*++s)) return 0;
8877         d = *s++ - '0';
8878         if (d > 6) return 0;
8879     }
8880
8881     if (*s == '/') {
8882         if (!isdigit(*++s)) return 0;
8883         hour = *s++ - '0';
8884         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8885         if (*s == ':') {
8886             if (!isdigit(*++s)) return 0;
8887             min = *s++ - '0';
8888             if (isdigit(*s)) min = 10*min + *s++ - '0';
8889             if (*s == ':') {
8890                 if (!isdigit(*++s)) return 0;
8891                 sec = *s++ - '0';
8892                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8893             }
8894         }
8895     } else {
8896         hour = 2;
8897         min = 0;
8898         sec = 0;
8899     }
8900
8901     if (dozjd) {
8902         if (w->tm_yday < d) goto before;
8903         if (w->tm_yday > d) goto after;
8904     } else {
8905         if (w->tm_mon+1 < m) goto before;
8906         if (w->tm_mon+1 > m) goto after;
8907
8908         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8909         k = d - j; /* mday of first d */
8910         if (k <= 0) k += 7;
8911         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8912         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8913         if (w->tm_mday < k) goto before;
8914         if (w->tm_mday > k) goto after;
8915     }
8916
8917     if (w->tm_hour < hour) goto before;
8918     if (w->tm_hour > hour) goto after;
8919     if (w->tm_min  < min)  goto before;
8920     if (w->tm_min  > min)  goto after;
8921     if (w->tm_sec  < sec)  goto before;
8922     goto after;
8923
8924 before:
8925     *past = 0;
8926     return s;
8927 after:
8928     *past = 1;
8929     return s;
8930 }
8931
8932
8933
8934
8935 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8936
8937 static char *
8938 tz_parse_offset(char *s, int *offset)
8939 {
8940     int hour = 0, min = 0, sec = 0;
8941     int neg = 0;
8942     if (!s) return 0;
8943     if (!offset) return 0;
8944
8945     if (*s == '-') {neg++; s++;}
8946     if (*s == '+') s++;
8947     if (!isdigit(*s)) return 0;
8948     hour = *s++ - '0';
8949     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8950     if (hour > 24) return 0;
8951     if (*s == ':') {
8952         if (!isdigit(*++s)) return 0;
8953         min = *s++ - '0';
8954         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8955         if (min > 59) return 0;
8956         if (*s == ':') {
8957             if (!isdigit(*++s)) return 0;
8958             sec = *s++ - '0';
8959             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8960             if (sec > 59) return 0;
8961         }
8962     }
8963
8964     *offset = (hour*60+min)*60 + sec;
8965     if (neg) *offset = -*offset;
8966     return s;
8967 }
8968
8969 /*
8970     input time is w, whatever type of time the CRTL localtime() uses.
8971     sets dst, the zone, and the gmtoff (seconds)
8972
8973     caches the value of TZ and UCX$TZ env variables; note that
8974     my_setenv looks for these and sets a flag if they're changed
8975     for efficiency.
8976
8977     We have to watch out for the "australian" case (dst starts in
8978     october, ends in april)...flagged by "reverse" and checked by
8979     scanning through the months of the previous year.
8980
8981 */
8982
8983 static int
8984 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8985 {
8986     time_t when;
8987     struct tm *w2;
8988     char *s,*s2;
8989     char *dstzone, *tz, *s_start, *s_end;
8990     int std_off, dst_off, isdst;
8991     int y, dststart, dstend;
8992     static char envtz[1025];  /* longer than any logical, symbol, ... */
8993     static char ucxtz[1025];
8994     static char reversed = 0;
8995
8996     if (!w) return 0;
8997
8998     if (tz_updated) {
8999         tz_updated = 0;
9000         reversed = -1;  /* flag need to check  */
9001         envtz[0] = ucxtz[0] = '\0';
9002         tz = my_getenv("TZ",0);
9003         if (tz) strcpy(envtz, tz);
9004         tz = my_getenv("UCX$TZ",0);
9005         if (tz) strcpy(ucxtz, tz);
9006         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9007     }
9008     tz = envtz;
9009     if (!*tz) tz = ucxtz;
9010
9011     s = tz;
9012     while (isalpha(*s)) s++;
9013     s = tz_parse_offset(s, &std_off);
9014     if (!s) return 0;
9015     if (!*s) {                  /* no DST, hurray we're done! */
9016         isdst = 0;
9017         goto done;
9018     }
9019
9020     dstzone = s;
9021     while (isalpha(*s)) s++;
9022     s2 = tz_parse_offset(s, &dst_off);
9023     if (s2) {
9024         s = s2;
9025     } else {
9026         dst_off = std_off - 3600;
9027     }
9028
9029     if (!*s) {      /* default dst start/end?? */
9030         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9031             s = strchr(ucxtz,',');
9032         }
9033         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9034     }
9035     if (*s != ',') return 0;
9036
9037     when = *w;
9038     when = _toutc(when);      /* convert to utc */
9039     when = when - std_off;    /* convert to pseudolocal time*/
9040
9041     w2 = localtime(&when);
9042     y = w2->tm_year;
9043     s_start = s+1;
9044     s = tz_parse_startend(s_start,w2,&dststart);
9045     if (!s) return 0;
9046     if (*s != ',') return 0;
9047
9048     when = *w;
9049     when = _toutc(when);      /* convert to utc */
9050     when = when - dst_off;    /* convert to pseudolocal time*/
9051     w2 = localtime(&when);
9052     if (w2->tm_year != y) {   /* spans a year, just check one time */
9053         when += dst_off - std_off;
9054         w2 = localtime(&when);
9055     }
9056     s_end = s+1;
9057     s = tz_parse_startend(s_end,w2,&dstend);
9058     if (!s) return 0;
9059
9060     if (reversed == -1) {  /* need to check if start later than end */
9061         int j, ds, de;
9062
9063         when = *w;
9064         if (when < 2*365*86400) {
9065             when += 2*365*86400;
9066         } else {
9067             when -= 365*86400;
9068         }
9069         w2 =localtime(&when);
9070         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9071
9072         for (j = 0; j < 12; j++) {
9073             w2 =localtime(&when);
9074             tz_parse_startend(s_start,w2,&ds);
9075             tz_parse_startend(s_end,w2,&de);
9076             if (ds != de) break;
9077             when += 30*86400;
9078         }
9079         reversed = 0;
9080         if (de && !ds) reversed = 1;
9081     }
9082
9083     isdst = dststart && !dstend;
9084     if (reversed) isdst = dststart  || !dstend;
9085
9086 done:
9087     if (dst)    *dst = isdst;
9088     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9089     if (isdst)  tz = dstzone;
9090     if (zone) {
9091         while(isalpha(*tz))  *zone++ = *tz++;
9092         *zone = '\0';
9093     }
9094     return 1;
9095 }
9096
9097 #endif /* !RTL_USES_UTC */
9098
9099 /* my_time(), my_localtime(), my_gmtime()
9100  * By default traffic in UTC time values, using CRTL gmtime() or
9101  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9102  * Note: We need to use these functions even when the CRTL has working
9103  * UTC support, since they also handle C<use vmsish qw(times);>
9104  *
9105  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9106  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9107  */
9108
9109 /*{{{time_t my_time(time_t *timep)*/
9110 time_t Perl_my_time(pTHX_ time_t *timep)
9111 {
9112   time_t when;
9113   struct tm *tm_p;
9114
9115   if (gmtime_emulation_type == 0) {
9116     int dstnow;
9117     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9118                               /* results of calls to gmtime() and localtime() */
9119                               /* for same &base */
9120
9121     gmtime_emulation_type++;
9122     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9123       char off[LNM$C_NAMLENGTH+1];;
9124
9125       gmtime_emulation_type++;
9126       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9127         gmtime_emulation_type++;
9128         utc_offset_secs = 0;
9129         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9130       }
9131       else { utc_offset_secs = atol(off); }
9132     }
9133     else { /* We've got a working gmtime() */
9134       struct tm gmt, local;
9135
9136       gmt = *tm_p;
9137       tm_p = localtime(&base);
9138       local = *tm_p;
9139       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9140       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9141       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9142       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9143     }
9144   }
9145
9146   when = time(NULL);
9147 # ifdef VMSISH_TIME
9148 # ifdef RTL_USES_UTC
9149   if (VMSISH_TIME) when = _toloc(when);
9150 # else
9151   if (!VMSISH_TIME) when = _toutc(when);
9152 # endif
9153 # endif
9154   if (timep != NULL) *timep = when;
9155   return when;
9156
9157 }  /* end of my_time() */
9158 /*}}}*/
9159
9160
9161 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9162 struct tm *
9163 Perl_my_gmtime(pTHX_ const time_t *timep)
9164 {
9165   char *p;
9166   time_t when;
9167   struct tm *rsltmp;
9168
9169   if (timep == NULL) {
9170     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9171     return NULL;
9172   }
9173   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9174
9175   when = *timep;
9176 # ifdef VMSISH_TIME
9177   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9178 #  endif
9179 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9180   return gmtime(&when);
9181 # else
9182   /* CRTL localtime() wants local time as input, so does no tz correction */
9183   rsltmp = localtime(&when);
9184   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9185   return rsltmp;
9186 #endif
9187 }  /* end of my_gmtime() */
9188 /*}}}*/
9189
9190
9191 /*{{{struct tm *my_localtime(const time_t *timep)*/
9192 struct tm *
9193 Perl_my_localtime(pTHX_ const time_t *timep)
9194 {
9195   time_t when, whenutc;
9196   struct tm *rsltmp;
9197   int dst, offset;
9198
9199   if (timep == NULL) {
9200     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9201     return NULL;
9202   }
9203   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9204   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9205
9206   when = *timep;
9207 # ifdef RTL_USES_UTC
9208 # ifdef VMSISH_TIME
9209   if (VMSISH_TIME) when = _toutc(when);
9210 # endif
9211   /* CRTL localtime() wants UTC as input, does tz correction itself */
9212   return localtime(&when);
9213
9214 # else /* !RTL_USES_UTC */
9215   whenutc = when;
9216 # ifdef VMSISH_TIME
9217   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9218   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9219 # endif
9220   dst = -1;
9221 #ifndef RTL_USES_UTC
9222   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9223       when = whenutc - offset;                   /* pseudolocal time*/
9224   }
9225 # endif
9226   /* CRTL localtime() wants local time as input, so does no tz correction */
9227   rsltmp = localtime(&when);
9228   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9229   return rsltmp;
9230 # endif
9231
9232 } /*  end of my_localtime() */
9233 /*}}}*/
9234
9235 /* Reset definitions for later calls */
9236 #define gmtime(t)    my_gmtime(t)
9237 #define localtime(t) my_localtime(t)
9238 #define time(t)      my_time(t)
9239
9240
9241 /* my_utime - update modification time of a file
9242  * calling sequence is identical to POSIX utime(), but under
9243  * VMS only the modification time is changed; ODS-2 does not
9244  * maintain access times.  Restrictions differ from the POSIX
9245  * definition in that the time can be changed as long as the
9246  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9247  * no separate checks are made to insure that the caller is the
9248  * owner of the file or has special privs enabled.
9249  * Code here is based on Joe Meadows' FILE utility.
9250  */
9251
9252 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9253  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9254  * in 100 ns intervals.
9255  */
9256 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9257
9258 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9259 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9260 {
9261   register int i;
9262   int sts;
9263   long int bintime[2], len = 2, lowbit, unixtime,
9264            secscale = 10000000; /* seconds --> 100 ns intervals */
9265   unsigned long int chan, iosb[2], retsts;
9266   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9267   struct FAB myfab = cc$rms_fab;
9268   struct NAM mynam = cc$rms_nam;
9269 #if defined (__DECC) && defined (__VAX)
9270   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9271    * at least through VMS V6.1, which causes a type-conversion warning.
9272    */
9273 #  pragma message save
9274 #  pragma message disable cvtdiftypes
9275 #endif
9276   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9277   struct fibdef myfib;
9278 #if defined (__DECC) && defined (__VAX)
9279   /* This should be right after the declaration of myatr, but due
9280    * to a bug in VAX DEC C, this takes effect a statement early.
9281    */
9282 #  pragma message restore
9283 #endif
9284   /* cast ok for read only parameter */
9285   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9286                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9287                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9288
9289   if (file == NULL || *file == '\0') {
9290     set_errno(ENOENT);
9291     set_vaxc_errno(LIB$_INVARG);
9292     return -1;
9293   }
9294   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9295
9296   if (utimes != NULL) {
9297     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9298      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9299      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9300      * as input, we force the sign bit to be clear by shifting unixtime right
9301      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9302      */
9303     lowbit = (utimes->modtime & 1) ? secscale : 0;
9304     unixtime = (long int) utimes->modtime;
9305 #   ifdef VMSISH_TIME
9306     /* If input was UTC; convert to local for sys svc */
9307     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9308 #   endif
9309     unixtime >>= 1;  secscale <<= 1;
9310     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9311     if (!(retsts & 1)) {
9312       set_errno(EVMSERR);
9313       set_vaxc_errno(retsts);
9314       return -1;
9315     }
9316     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9317     if (!(retsts & 1)) {
9318       set_errno(EVMSERR);
9319       set_vaxc_errno(retsts);
9320       return -1;
9321     }
9322   }
9323   else {
9324     /* Just get the current time in VMS format directly */
9325     retsts = sys$gettim(bintime);
9326     if (!(retsts & 1)) {
9327       set_errno(EVMSERR);
9328       set_vaxc_errno(retsts);
9329       return -1;
9330     }
9331   }
9332
9333   myfab.fab$l_fna = vmsspec;
9334   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9335   myfab.fab$l_nam = &mynam;
9336   mynam.nam$l_esa = esa;
9337   mynam.nam$b_ess = (unsigned char) sizeof esa;
9338   mynam.nam$l_rsa = rsa;
9339   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9340   if (decc_efs_case_preserve)
9341       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9342
9343   /* Look for the file to be affected, letting RMS parse the file
9344    * specification for us as well.  I have set errno using only
9345    * values documented in the utime() man page for VMS POSIX.
9346    */
9347   retsts = sys$parse(&myfab,0,0);
9348   if (!(retsts & 1)) {
9349     set_vaxc_errno(retsts);
9350     if      (retsts == RMS$_PRV) set_errno(EACCES);
9351     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9352     else                         set_errno(EVMSERR);
9353     return -1;
9354   }
9355   retsts = sys$search(&myfab,0,0);
9356   if (!(retsts & 1)) {
9357     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9358     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9359     set_vaxc_errno(retsts);
9360     if      (retsts == RMS$_PRV) set_errno(EACCES);
9361     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9362     else                         set_errno(EVMSERR);
9363     return -1;
9364   }
9365
9366   devdsc.dsc$w_length = mynam.nam$b_dev;
9367   /* cast ok for read only parameter */
9368   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9369
9370   retsts = sys$assign(&devdsc,&chan,0,0);
9371   if (!(retsts & 1)) {
9372     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9373     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9374     set_vaxc_errno(retsts);
9375     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9376     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9377     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9378     else                               set_errno(EVMSERR);
9379     return -1;
9380   }
9381
9382   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9383   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9384
9385   memset((void *) &myfib, 0, sizeof myfib);
9386 #if defined(__DECC) || defined(__DECCXX)
9387   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9388   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9389   /* This prevents the revision time of the file being reset to the current
9390    * time as a result of our IO$_MODIFY $QIO. */
9391   myfib.fib$l_acctl = FIB$M_NORECORD;
9392 #else
9393   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9394   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9395   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9396 #endif
9397   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9398   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9399   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9400   _ckvmssts(sys$dassgn(chan));
9401   if (retsts & 1) retsts = iosb[0];
9402   if (!(retsts & 1)) {
9403     set_vaxc_errno(retsts);
9404     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9405     else                      set_errno(EVMSERR);
9406     return -1;
9407   }
9408
9409   return 0;
9410 }  /* end of my_utime() */
9411 /*}}}*/
9412
9413 /*
9414  * flex_stat, flex_lstat, flex_fstat
9415  * basic stat, but gets it right when asked to stat
9416  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9417  */
9418
9419 #ifndef _USE_STD_STAT
9420 /* encode_dev packs a VMS device name string into an integer to allow
9421  * simple comparisons. This can be used, for example, to check whether two
9422  * files are located on the same device, by comparing their encoded device
9423  * names. Even a string comparison would not do, because stat() reuses the
9424  * device name buffer for each call; so without encode_dev, it would be
9425  * necessary to save the buffer and use strcmp (this would mean a number of
9426  * changes to the standard Perl code, to say nothing of what a Perl script
9427  * would have to do.
9428  *
9429  * The device lock id, if it exists, should be unique (unless perhaps compared
9430  * with lock ids transferred from other nodes). We have a lock id if the disk is
9431  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9432  * device names. Thus we use the lock id in preference, and only if that isn't
9433  * available, do we try to pack the device name into an integer (flagged by
9434  * the sign bit (LOCKID_MASK) being set).
9435  *
9436  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9437  * name and its encoded form, but it seems very unlikely that we will find
9438  * two files on different disks that share the same encoded device names,
9439  * and even more remote that they will share the same file id (if the test
9440  * is to check for the same file).
9441  *
9442  * A better method might be to use sys$device_scan on the first call, and to
9443  * search for the device, returning an index into the cached array.
9444  * The number returned would be more intelligable.
9445  * This is probably not worth it, and anyway would take quite a bit longer
9446  * on the first call.
9447  */
9448 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9449 static mydev_t encode_dev (pTHX_ const char *dev)
9450 {
9451   int i;
9452   unsigned long int f;
9453   mydev_t enc;
9454   char c;
9455   const char *q;
9456
9457   if (!dev || !dev[0]) return 0;
9458
9459 #if LOCKID_MASK
9460   {
9461     struct dsc$descriptor_s dev_desc;
9462     unsigned long int status, lockid, item = DVI$_LOCKID;
9463
9464     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9465        can try that first. */
9466     dev_desc.dsc$w_length =  strlen (dev);
9467     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9468     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9469     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9470     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9471     if (lockid) return (lockid & ~LOCKID_MASK);
9472   }
9473 #endif
9474
9475   /* Otherwise we try to encode the device name */
9476   enc = 0;
9477   f = 1;
9478   i = 0;
9479   for (q = dev + strlen(dev); q--; q >= dev) {
9480     if (isdigit (*q))
9481       c= (*q) - '0';
9482     else if (isalpha (toupper (*q)))
9483       c= toupper (*q) - 'A' + (char)10;
9484     else
9485       continue; /* Skip '$'s */
9486     i++;
9487     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9488     if (i>1) f *= 36;
9489     enc += f * (unsigned long int) c;
9490   }
9491   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9492
9493 }  /* end of encode_dev() */
9494 #endif
9495
9496 static char namecache[NAM$C_MAXRSS+1];
9497
9498 static int
9499 is_null_device(name)
9500     const char *name;
9501 {
9502   if (decc_bug_devnull != 0) {
9503     if (strncmp("/dev/null", name, 9) == 0)
9504       return 1;
9505   }
9506     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9507        The underscore prefix, controller letter, and unit number are
9508        independently optional; for our purposes, the colon punctuation
9509        is not.  The colon can be trailed by optional directory and/or
9510        filename, but two consecutive colons indicates a nodename rather
9511        than a device.  [pr]  */
9512   if (*name == '_') ++name;
9513   if (tolower(*name++) != 'n') return 0;
9514   if (tolower(*name++) != 'l') return 0;
9515   if (tolower(*name) == 'a') ++name;
9516   if (*name == '0') ++name;
9517   return (*name++ == ':') && (*name != ':');
9518 }
9519
9520 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9521 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9522  * subset of the applicable information.
9523  */
9524 bool
9525 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9526 {
9527   char fname_phdev[NAM$C_MAXRSS+1];
9528 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9529   /* Namecache not workable with symbolic links, as symbolic links do
9530    *  not have extensions and directories do in VMS mode.  So in order
9531    *  to test this, the did and ino_t must be used.
9532    *
9533    * Fix-me - Hide the information in the new stat structure
9534    *          Get rid of the namecache.
9535    */
9536   if (decc_posix_compliant_pathnames == 0)
9537 #endif
9538       if (statbufp == &PL_statcache)
9539           return cando_by_name(bit,effective,namecache);
9540   {
9541     char fname[NAM$C_MAXRSS+1];
9542     unsigned long int retsts;
9543     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9544                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9545
9546     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9547        device name on successive calls */
9548     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9549     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9550     namdsc.dsc$a_pointer = fname;
9551     namdsc.dsc$w_length = sizeof fname - 1;
9552
9553     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9554                              &namdsc,&namdsc.dsc$w_length,0,0);
9555     if (retsts & 1) {
9556       fname[namdsc.dsc$w_length] = '\0';
9557 /*
9558  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9559  * but if someone has redefined that logical, Perl gets very lost.  Since
9560  * we have the physical device name from the stat buffer, just paste it on.
9561  */
9562       strcpy( fname_phdev, statbufp->st_devnam );
9563       strcat( fname_phdev, strrchr(fname, ':') );
9564
9565       return cando_by_name(bit,effective,fname_phdev);
9566     }
9567     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9568       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9569       return FALSE;
9570     }
9571     _ckvmssts(retsts);
9572     return FALSE;  /* Should never get to here */
9573   }
9574 }  /* end of cando() */
9575 /*}}}*/
9576
9577
9578 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9579 I32
9580 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9581 {
9582   static char usrname[L_cuserid];
9583   static struct dsc$descriptor_s usrdsc =
9584          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9585   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9586   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9587   unsigned short int retlen, trnlnm_iter_count;
9588   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9589   union prvdef curprv;
9590   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9591          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9592   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9593          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9594          {0,0,0,0}};
9595   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9596          {0,0,0,0}};
9597   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9598
9599   if (!fname || !*fname) return FALSE;
9600   /* Make sure we expand logical names, since sys$check_access doesn't */
9601   if (!strpbrk(fname,"/]>:")) {
9602     strcpy(fileified,fname);
9603     trnlnm_iter_count = 0;
9604     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9605         trnlnm_iter_count++;
9606         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9607     }
9608     fname = fileified;
9609   }
9610   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9611   retlen = namdsc.dsc$w_length = strlen(vmsname);
9612   namdsc.dsc$a_pointer = vmsname;
9613   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9614       vmsname[retlen-1] == ':') {
9615     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9616     namdsc.dsc$w_length = strlen(fileified);
9617     namdsc.dsc$a_pointer = fileified;
9618   }
9619
9620   switch (bit) {
9621     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9622       access = ARM$M_EXECUTE; break;
9623     case S_IRUSR: case S_IRGRP: case S_IROTH:
9624       access = ARM$M_READ; break;
9625     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9626       access = ARM$M_WRITE; break;
9627     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9628       access = ARM$M_DELETE; break;
9629     default:
9630       return FALSE;
9631   }
9632
9633   /* Before we call $check_access, create a user profile with the current
9634    * process privs since otherwise it just uses the default privs from the
9635    * UAF and might give false positives or negatives.  This only works on
9636    * VMS versions v6.0 and later since that's when sys$create_user_profile
9637    * became available.
9638    */
9639
9640   /* get current process privs and username */
9641   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9642   _ckvmssts(iosb[0]);
9643
9644 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9645
9646   /* find out the space required for the profile */
9647   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9648                                     &usrprodsc.dsc$w_length,0));
9649
9650   /* allocate space for the profile and get it filled in */
9651   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9652   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9653                                     &usrprodsc.dsc$w_length,0));
9654
9655   /* use the profile to check access to the file; free profile & analyze results */
9656   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9657   Safefree(usrprodsc.dsc$a_pointer);
9658   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9659
9660 #else
9661
9662   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9663
9664 #endif
9665
9666   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9667       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9668       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9669     set_vaxc_errno(retsts);
9670     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9671     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9672     else set_errno(ENOENT);
9673     return FALSE;
9674   }
9675   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9676     return TRUE;
9677   }
9678   _ckvmssts(retsts);
9679
9680   return FALSE;  /* Should never get here */
9681
9682 }  /* end of cando_by_name() */
9683 /*}}}*/
9684
9685
9686 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9687 int
9688 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9689 {
9690   if (!fstat(fd,(stat_t *) statbufp)) {
9691     if (statbufp == (Stat_t *) &PL_statcache) {
9692     char *cptr;
9693
9694         /* Save name for cando by name in VMS format */
9695         cptr = getname(fd, namecache, 1);
9696
9697         /* This should not happen, but just in case */
9698         if (cptr == NULL)
9699            namecache[0] = '\0';
9700     }
9701
9702     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
9703 #ifndef _USE_STD_STAT
9704     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9705     statbufp->st_devnam[63] = 0;
9706     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9707 #else
9708     /* todo:
9709      * The device is only encoded so that Perl_cando can use it to
9710      * look up ACLS.  So rmsexpand it to the 255 character version
9711      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9712      * for long filenames and symbolic links first.  This also seems
9713      * to remove the need for a namecache that could be stale.
9714      */
9715 #endif
9716
9717 #   ifdef RTL_USES_UTC
9718 #   ifdef VMSISH_TIME
9719     if (VMSISH_TIME) {
9720       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9721       statbufp->st_atime = _toloc(statbufp->st_atime);
9722       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9723     }
9724 #   endif
9725 #   else
9726 #   ifdef VMSISH_TIME
9727     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9728 #   else
9729     if (1) {
9730 #   endif
9731       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9732       statbufp->st_atime = _toutc(statbufp->st_atime);
9733       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9734     }
9735 #endif
9736     return 0;
9737   }
9738   return -1;
9739
9740 }  /* end of flex_fstat() */
9741 /*}}}*/
9742
9743 #if !defined(__VAX) && __CRTL_VER >= 80200000
9744 #ifdef lstat
9745 #undef lstat
9746 #endif
9747 #else
9748 #ifdef lstat
9749 #undef lstat
9750 #endif
9751 #define lstat(_x, _y) stat(_x, _y)
9752 #endif
9753
9754 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9755
9756 static int
9757 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9758 {
9759     char fileified[NAM$C_MAXRSS+1];
9760     char temp_fspec[NAM$C_MAXRSS+300];
9761     int retval = -1;
9762     int saved_errno, saved_vaxc_errno;
9763
9764     if (!fspec) return retval;
9765     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9766     strcpy(temp_fspec, fspec);
9767     if (statbufp == (Stat_t *) &PL_statcache)
9768       do_tovmsspec(temp_fspec,namecache,0);
9769     if (decc_bug_devnull != 0) {
9770       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9771         memset(statbufp,0,sizeof *statbufp);
9772         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9773         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9774         statbufp->st_uid = 0x00010001;
9775         statbufp->st_gid = 0x0001;
9776         time((time_t *)&statbufp->st_mtime);
9777         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9778         return 0;
9779       }
9780     }
9781
9782     /* Try for a directory name first.  If fspec contains a filename without
9783      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9784      * and sea:[wine.dark]water. exist, we prefer the directory here.
9785      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9786      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9787      * the file with null type, specify this by calling flex_stat() with
9788      * a '.' at the end of fspec.
9789      *
9790      * If we are in Posix filespec mode, accept the filename as is.
9791      */
9792 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9793   if (decc_posix_compliant_pathnames == 0) {
9794 #endif
9795     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9796       if (lstat_flag == 0)
9797         retval = stat(fileified,(stat_t *) statbufp);
9798       else
9799         retval = lstat(fileified,(stat_t *) statbufp);
9800       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9801         strcpy(namecache,fileified);
9802     }
9803     if (retval) {
9804       if (lstat_flag == 0)
9805         retval = stat(temp_fspec,(stat_t *) statbufp);
9806       else
9807         retval = lstat(temp_fspec,(stat_t *) statbufp);
9808     }
9809 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9810   } else {
9811     if (lstat_flag == 0)
9812       retval = stat(temp_fspec,(stat_t *) statbufp);
9813     else
9814       retval = lstat(temp_fspec,(stat_t *) statbufp);
9815   }
9816 #endif
9817     if (!retval) {
9818       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
9819 #ifndef _USE_STD_STAT
9820       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9821       statbufp->st_devnam[63] = 0;
9822       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9823 #else
9824     /* todo:
9825      * The device is only encoded so that Perl_cando can use it to
9826      * look up ACLS.  So rmsexpand it to the 255 character version
9827      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9828      * for long filenames and symbolic links first.  This also seems
9829      * to remove the need for a namecache that could be stale.
9830      */
9831 #endif
9832 #     ifdef RTL_USES_UTC
9833 #     ifdef VMSISH_TIME
9834       if (VMSISH_TIME) {
9835         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9836         statbufp->st_atime = _toloc(statbufp->st_atime);
9837         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9838       }
9839 #     endif
9840 #     else
9841 #     ifdef VMSISH_TIME
9842       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9843 #     else
9844       if (1) {
9845 #     endif
9846         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9847         statbufp->st_atime = _toutc(statbufp->st_atime);
9848         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9849       }
9850 #     endif
9851     }
9852     /* If we were successful, leave errno where we found it */
9853     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9854     return retval;
9855
9856 }  /* end of flex_stat_int() */
9857
9858
9859 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9860 int
9861 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9862 {
9863    return flex_stat_int(fspec, statbufp, 0);
9864 }
9865 /*}}}*/
9866
9867 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9868 int
9869 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9870 {
9871    return flex_stat_int(fspec, statbufp, 1);
9872 }
9873 /*}}}*/
9874
9875
9876 /*{{{char *my_getlogin()*/
9877 /* VMS cuserid == Unix getlogin, except calling sequence */
9878 char *
9879 my_getlogin(void)
9880 {
9881     static char user[L_cuserid];
9882     return cuserid(user);
9883 }
9884 /*}}}*/
9885
9886
9887 /*  rmscopy - copy a file using VMS RMS routines
9888  *
9889  *  Copies contents and attributes of spec_in to spec_out, except owner
9890  *  and protection information.  Name and type of spec_in are used as
9891  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9892  *  should try to propagate timestamps from the input file to the output file.
9893  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9894  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9895  *  propagated to the output file at creation iff the output file specification
9896  *  did not contain an explicit name or type, and the revision date is always
9897  *  updated at the end of the copy operation.  If it is greater than 0, then
9898  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9899  *  other than the revision date should be propagated, and bit 1 indicates
9900  *  that the revision date should be propagated.
9901  *
9902  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9903  *
9904  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9905  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9906  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9907  * as part of the Perl standard distribution under the terms of the
9908  * GNU General Public License or the Perl Artistic License.  Copies
9909  * of each may be found in the Perl standard distribution.
9910  */ /* FIXME */
9911 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9912 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9913 int
9914 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9915 {
9916     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9917          rsa[NAM$C_MAXRSS], ubf[32256];
9918     unsigned long int i, sts, sts2;
9919     struct FAB fab_in, fab_out;
9920     struct RAB rab_in, rab_out;
9921     struct NAM nam;
9922     struct XABDAT xabdat;
9923     struct XABFHC xabfhc;
9924     struct XABRDT xabrdt;
9925     struct XABSUM xabsum;
9926
9927     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9928         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9929       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9930       return 0;
9931     }
9932
9933     fab_in = cc$rms_fab;
9934     fab_in.fab$l_fna = vmsin;
9935     fab_in.fab$b_fns = strlen(vmsin);
9936     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9937     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9938     fab_in.fab$l_fop = FAB$M_SQO;
9939     fab_in.fab$l_nam =  &nam;
9940     fab_in.fab$l_xab = (void *) &xabdat;
9941
9942     nam = cc$rms_nam;
9943     nam.nam$l_rsa = rsa;
9944     nam.nam$b_rss = sizeof(rsa);
9945     nam.nam$l_esa = esa;
9946     nam.nam$b_ess = sizeof (esa);
9947     nam.nam$b_esl = nam.nam$b_rsl = 0;
9948 #ifdef NAM$M_NO_SHORT_UPCASE
9949     if (decc_efs_case_preserve)
9950         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9951 #endif
9952
9953     xabdat = cc$rms_xabdat;        /* To get creation date */
9954     xabdat.xab$l_nxt = (void *) &xabfhc;
9955
9956     xabfhc = cc$rms_xabfhc;        /* To get record length */
9957     xabfhc.xab$l_nxt = (void *) &xabsum;
9958
9959     xabsum = cc$rms_xabsum;        /* To get key and area information */
9960
9961     if (!((sts = sys$open(&fab_in)) & 1)) {
9962       set_vaxc_errno(sts);
9963       switch (sts) {
9964         case RMS$_FNF: case RMS$_DNF:
9965           set_errno(ENOENT); break;
9966         case RMS$_DIR:
9967           set_errno(ENOTDIR); break;
9968         case RMS$_DEV:
9969           set_errno(ENODEV); break;
9970         case RMS$_SYN:
9971           set_errno(EINVAL); break;
9972         case RMS$_PRV:
9973           set_errno(EACCES); break;
9974         default:
9975           set_errno(EVMSERR);
9976       }
9977       return 0;
9978     }
9979
9980     fab_out = fab_in;
9981     fab_out.fab$w_ifi = 0;
9982     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9983     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9984     fab_out.fab$l_fop = FAB$M_SQO;
9985     fab_out.fab$l_fna = vmsout;
9986     fab_out.fab$b_fns = strlen(vmsout);
9987     fab_out.fab$l_dna = nam.nam$l_name;
9988     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
9989
9990     if (preserve_dates == 0) {  /* Act like DCL COPY */
9991       nam.nam$b_nop |= NAM$M_SYNCHK;
9992       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
9993       if (!((sts = sys$parse(&fab_out)) & 1)) {
9994         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9995         set_vaxc_errno(sts);
9996         return 0;
9997       }
9998       fab_out.fab$l_xab = (void *) &xabdat;
9999       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10000     }
10001     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10002     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10003       preserve_dates =0;      /* bitmask from this point forward   */
10004
10005     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10006     if (!((sts = sys$create(&fab_out)) & 1)) {
10007       set_vaxc_errno(sts);
10008       switch (sts) {
10009         case RMS$_DNF:
10010           set_errno(ENOENT); break;
10011         case RMS$_DIR:
10012           set_errno(ENOTDIR); break;
10013         case RMS$_DEV:
10014           set_errno(ENODEV); break;
10015         case RMS$_SYN:
10016           set_errno(EINVAL); break;
10017         case RMS$_PRV:
10018           set_errno(EACCES); break;
10019         default:
10020           set_errno(EVMSERR);
10021       }
10022       return 0;
10023     }
10024     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10025     if (preserve_dates & 2) {
10026       /* sys$close() will process xabrdt, not xabdat */
10027       xabrdt = cc$rms_xabrdt;
10028 #ifndef __GNUC__
10029       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10030 #else
10031       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10032        * is unsigned long[2], while DECC & VAXC use a struct */
10033       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10034 #endif
10035       fab_out.fab$l_xab = (void *) &xabrdt;
10036     }
10037
10038     rab_in = cc$rms_rab;
10039     rab_in.rab$l_fab = &fab_in;
10040     rab_in.rab$l_rop = RAB$M_BIO;
10041     rab_in.rab$l_ubf = ubf;
10042     rab_in.rab$w_usz = sizeof ubf;
10043     if (!((sts = sys$connect(&rab_in)) & 1)) {
10044       sys$close(&fab_in); sys$close(&fab_out);
10045       set_errno(EVMSERR); set_vaxc_errno(sts);
10046       return 0;
10047     }
10048
10049     rab_out = cc$rms_rab;
10050     rab_out.rab$l_fab = &fab_out;
10051     rab_out.rab$l_rbf = ubf;
10052     if (!((sts = sys$connect(&rab_out)) & 1)) {
10053       sys$close(&fab_in); sys$close(&fab_out);
10054       set_errno(EVMSERR); set_vaxc_errno(sts);
10055       return 0;
10056     }
10057
10058     while ((sts = sys$read(&rab_in))) {  /* always true  */
10059       if (sts == RMS$_EOF) break;
10060       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10061       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10062         sys$close(&fab_in); sys$close(&fab_out);
10063         set_errno(EVMSERR); set_vaxc_errno(sts);
10064         return 0;
10065       }
10066     }
10067
10068     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10069     sys$close(&fab_in);  sys$close(&fab_out);
10070     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10071     if (!(sts & 1)) {
10072       set_errno(EVMSERR); set_vaxc_errno(sts);
10073       return 0;
10074     }
10075
10076     return 1;
10077
10078 }  /* end of rmscopy() */
10079 #else
10080 /* ODS-5 support version */
10081 int
10082 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10083 {
10084     char *vmsin, * vmsout, *esa, *esa_out,
10085          *rsa, *ubf;
10086     unsigned long int i, sts, sts2;
10087     struct FAB fab_in, fab_out;
10088     struct RAB rab_in, rab_out;
10089     struct NAML nam;
10090     struct NAML nam_out;
10091     struct XABDAT xabdat;
10092     struct XABFHC xabfhc;
10093     struct XABRDT xabrdt;
10094     struct XABSUM xabsum;
10095
10096     Newx(vmsin, VMS_MAXRSS, char);
10097     Newx(vmsout, VMS_MAXRSS, char);
10098     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10099         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10100       Safefree(vmsin);
10101       Safefree(vmsout);
10102       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10103       return 0;
10104     }
10105
10106     Newx(esa, VMS_MAXRSS, char);
10107     nam = cc$rms_naml;
10108     fab_in = cc$rms_fab;
10109     fab_in.fab$l_fna = (char *) -1;
10110     fab_in.fab$b_fns = 0;
10111     nam.naml$l_long_filename = vmsin;
10112     nam.naml$l_long_filename_size = strlen(vmsin);
10113     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10114     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10115     fab_in.fab$l_fop = FAB$M_SQO;
10116     fab_in.fab$l_naml =  &nam;
10117     fab_in.fab$l_xab = (void *) &xabdat;
10118
10119     Newx(rsa, VMS_MAXRSS, char);
10120     nam.naml$l_rsa = NULL;
10121     nam.naml$b_rss = 0;
10122     nam.naml$l_long_result = rsa;
10123     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10124     nam.naml$l_esa = NULL;
10125     nam.naml$b_ess = 0;
10126     nam.naml$l_long_expand = esa;
10127     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10128     nam.naml$b_esl = nam.naml$b_rsl = 0;
10129     nam.naml$l_long_expand_size = 0;
10130     nam.naml$l_long_result_size = 0;
10131 #ifdef NAM$M_NO_SHORT_UPCASE
10132     if (decc_efs_case_preserve)
10133         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10134 #endif
10135
10136     xabdat = cc$rms_xabdat;        /* To get creation date */
10137     xabdat.xab$l_nxt = (void *) &xabfhc;
10138
10139     xabfhc = cc$rms_xabfhc;        /* To get record length */
10140     xabfhc.xab$l_nxt = (void *) &xabsum;
10141
10142     xabsum = cc$rms_xabsum;        /* To get key and area information */
10143
10144     if (!((sts = sys$open(&fab_in)) & 1)) {
10145       Safefree(vmsin);
10146       Safefree(vmsout);
10147       Safefree(esa);
10148       Safefree(rsa);
10149       set_vaxc_errno(sts);
10150       switch (sts) {
10151         case RMS$_FNF: case RMS$_DNF:
10152           set_errno(ENOENT); break;
10153         case RMS$_DIR:
10154           set_errno(ENOTDIR); break;
10155         case RMS$_DEV:
10156           set_errno(ENODEV); break;
10157         case RMS$_SYN:
10158           set_errno(EINVAL); break;
10159         case RMS$_PRV:
10160           set_errno(EACCES); break;
10161         default:
10162           set_errno(EVMSERR);
10163       }
10164       return 0;
10165     }
10166
10167     nam_out = nam;
10168     fab_out = fab_in;
10169     fab_out.fab$w_ifi = 0;
10170     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10171     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10172     fab_out.fab$l_fop = FAB$M_SQO;
10173     fab_out.fab$l_naml = &nam_out;
10174     fab_out.fab$l_fna = (char *) -1;
10175     fab_out.fab$b_fns = 0;
10176     nam_out.naml$l_long_filename = vmsout;
10177     nam_out.naml$l_long_filename_size = strlen(vmsout);
10178     fab_out.fab$l_dna = (char *) -1;
10179     fab_out.fab$b_dns = 0;
10180     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10181     nam_out.naml$l_long_defname_size =
10182         nam.naml$l_long_name ?
10183            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10184
10185     Newx(esa_out, VMS_MAXRSS, char);
10186     nam_out.naml$l_rsa = NULL;
10187     nam_out.naml$b_rss = 0;
10188     nam_out.naml$l_long_result = NULL;
10189     nam_out.naml$l_long_result_alloc = 0;
10190     nam_out.naml$l_esa = NULL;
10191     nam_out.naml$b_ess = 0;
10192     nam_out.naml$l_long_expand = esa_out;
10193     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10194
10195     if (preserve_dates == 0) {  /* Act like DCL COPY */
10196       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10197       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10198       if (!((sts = sys$parse(&fab_out)) & 1)) {
10199         Safefree(vmsin);
10200         Safefree(vmsout);
10201         Safefree(esa);
10202         Safefree(rsa);
10203         Safefree(esa_out);
10204         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10205         set_vaxc_errno(sts);
10206         return 0;
10207       }
10208       fab_out.fab$l_xab = (void *) &xabdat;
10209       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10210     }
10211     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10212       preserve_dates =0;      /* bitmask from this point forward   */
10213
10214     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10215     if (!((sts = sys$create(&fab_out)) & 1)) {
10216       Safefree(vmsin);
10217       Safefree(vmsout);
10218       Safefree(esa);
10219       Safefree(rsa);
10220       Safefree(esa_out);
10221       set_vaxc_errno(sts);
10222       switch (sts) {
10223         case RMS$_DNF:
10224           set_errno(ENOENT); break;
10225         case RMS$_DIR:
10226           set_errno(ENOTDIR); break;
10227         case RMS$_DEV:
10228           set_errno(ENODEV); break;
10229         case RMS$_SYN:
10230           set_errno(EINVAL); break;
10231         case RMS$_PRV:
10232           set_errno(EACCES); break;
10233         default:
10234           set_errno(EVMSERR);
10235       }
10236       return 0;
10237     }
10238     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10239     if (preserve_dates & 2) {
10240       /* sys$close() will process xabrdt, not xabdat */
10241       xabrdt = cc$rms_xabrdt;
10242 #ifndef __GNUC__
10243       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10244 #else
10245       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10246        * is unsigned long[2], while DECC & VAXC use a struct */
10247       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10248 #endif
10249       fab_out.fab$l_xab = (void *) &xabrdt;
10250     }
10251
10252     Newx(ubf, 32256, char);
10253     rab_in = cc$rms_rab;
10254     rab_in.rab$l_fab = &fab_in;
10255     rab_in.rab$l_rop = RAB$M_BIO;
10256     rab_in.rab$l_ubf = ubf;
10257     rab_in.rab$w_usz = 32256;
10258     if (!((sts = sys$connect(&rab_in)) & 1)) {
10259       sys$close(&fab_in); sys$close(&fab_out);
10260       Safefree(vmsin);
10261       Safefree(vmsout);
10262       Safefree(esa);
10263       Safefree(ubf);
10264       Safefree(rsa);
10265       Safefree(esa_out);
10266       set_errno(EVMSERR); set_vaxc_errno(sts);
10267       return 0;
10268     }
10269
10270     rab_out = cc$rms_rab;
10271     rab_out.rab$l_fab = &fab_out;
10272     rab_out.rab$l_rbf = ubf;
10273     if (!((sts = sys$connect(&rab_out)) & 1)) {
10274       sys$close(&fab_in); sys$close(&fab_out);
10275       Safefree(vmsin);
10276       Safefree(vmsout);
10277       Safefree(esa);
10278       Safefree(ubf);
10279       Safefree(rsa);
10280       Safefree(esa_out);
10281       set_errno(EVMSERR); set_vaxc_errno(sts);
10282       return 0;
10283     }
10284
10285     while ((sts = sys$read(&rab_in))) {  /* always true  */
10286       if (sts == RMS$_EOF) break;
10287       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10288       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10289         sys$close(&fab_in); sys$close(&fab_out);
10290         Safefree(vmsin);
10291         Safefree(vmsout);
10292         Safefree(esa);
10293         Safefree(ubf);
10294         Safefree(rsa);
10295         Safefree(esa_out);
10296         set_errno(EVMSERR); set_vaxc_errno(sts);
10297         return 0;
10298       }
10299     }
10300
10301
10302     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10303     sys$close(&fab_in);  sys$close(&fab_out);
10304     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10305     if (!(sts & 1)) {
10306       Safefree(vmsin);
10307       Safefree(vmsout);
10308       Safefree(esa);
10309       Safefree(ubf);
10310       Safefree(rsa);
10311       Safefree(esa_out);
10312       set_errno(EVMSERR); set_vaxc_errno(sts);
10313       return 0;
10314     }
10315
10316     Safefree(vmsin);
10317     Safefree(vmsout);
10318     Safefree(esa);
10319     Safefree(ubf);
10320     Safefree(rsa);
10321     Safefree(esa_out);
10322     return 1;
10323
10324 }  /* end of rmscopy() */
10325 #endif
10326 /*}}}*/
10327
10328
10329 /***  The following glue provides 'hooks' to make some of the routines
10330  * from this file available from Perl.  These routines are sufficiently
10331  * basic, and are required sufficiently early in the build process,
10332  * that's it's nice to have them available to miniperl as well as the
10333  * full Perl, so they're set up here instead of in an extension.  The
10334  * Perl code which handles importation of these names into a given
10335  * package lives in [.VMS]Filespec.pm in @INC.
10336  */
10337
10338 void
10339 rmsexpand_fromperl(pTHX_ CV *cv)
10340 {
10341   dXSARGS;
10342   char *fspec, *defspec = NULL, *rslt;
10343   STRLEN n_a;
10344
10345   if (!items || items > 2)
10346     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10347   fspec = SvPV(ST(0),n_a);
10348   if (!fspec || !*fspec) XSRETURN_UNDEF;
10349   if (items == 2) defspec = SvPV(ST(1),n_a);
10350
10351   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10352   ST(0) = sv_newmortal();
10353   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10354   XSRETURN(1);
10355 }
10356
10357 void
10358 vmsify_fromperl(pTHX_ CV *cv)
10359 {
10360   dXSARGS;
10361   char *vmsified;
10362   STRLEN n_a;
10363
10364   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10365   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10366   ST(0) = sv_newmortal();
10367   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10368   XSRETURN(1);
10369 }
10370
10371 void
10372 unixify_fromperl(pTHX_ CV *cv)
10373 {
10374   dXSARGS;
10375   char *unixified;
10376   STRLEN n_a;
10377
10378   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10379   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10380   ST(0) = sv_newmortal();
10381   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10382   XSRETURN(1);
10383 }
10384
10385 void
10386 fileify_fromperl(pTHX_ CV *cv)
10387 {
10388   dXSARGS;
10389   char *fileified;
10390   STRLEN n_a;
10391
10392   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10393   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10394   ST(0) = sv_newmortal();
10395   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10396   XSRETURN(1);
10397 }
10398
10399 void
10400 pathify_fromperl(pTHX_ CV *cv)
10401 {
10402   dXSARGS;
10403   char *pathified;
10404   STRLEN n_a;
10405
10406   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10407   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10408   ST(0) = sv_newmortal();
10409   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10410   XSRETURN(1);
10411 }
10412
10413 void
10414 vmspath_fromperl(pTHX_ CV *cv)
10415 {
10416   dXSARGS;
10417   char *vmspath;
10418   STRLEN n_a;
10419
10420   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10421   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10422   ST(0) = sv_newmortal();
10423   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10424   XSRETURN(1);
10425 }
10426
10427 void
10428 unixpath_fromperl(pTHX_ CV *cv)
10429 {
10430   dXSARGS;
10431   char *unixpath;
10432   STRLEN n_a;
10433
10434   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10435   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10436   ST(0) = sv_newmortal();
10437   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10438   XSRETURN(1);
10439 }
10440
10441 void
10442 candelete_fromperl(pTHX_ CV *cv)
10443 {
10444   dXSARGS;
10445   char fspec[NAM$C_MAXRSS+1], *fsp;
10446   SV *mysv;
10447   IO *io;
10448   STRLEN n_a;
10449
10450   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10451
10452   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10453   if (SvTYPE(mysv) == SVt_PVGV) {
10454     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10455       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10456       ST(0) = &PL_sv_no;
10457       XSRETURN(1);
10458     }
10459     fsp = fspec;
10460   }
10461   else {
10462     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10463       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10464       ST(0) = &PL_sv_no;
10465       XSRETURN(1);
10466     }
10467   }
10468
10469   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10470   XSRETURN(1);
10471 }
10472
10473 void
10474 rmscopy_fromperl(pTHX_ CV *cv)
10475 {
10476   dXSARGS;
10477   char *inspec, *outspec, *inp, *outp;
10478   int date_flag;
10479   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10480                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10481   unsigned long int sts;
10482   SV *mysv;
10483   IO *io;
10484   STRLEN n_a;
10485
10486   if (items < 2 || items > 3)
10487     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10488
10489   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10490   Newx(inspec, VMS_MAXRSS, char);
10491   if (SvTYPE(mysv) == SVt_PVGV) {
10492     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10493       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10494       ST(0) = &PL_sv_no;
10495       Safefree(inspec);
10496       XSRETURN(1);
10497     }
10498     inp = inspec;
10499   }
10500   else {
10501     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10502       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10503       ST(0) = &PL_sv_no;
10504       Safefree(inspec);
10505       XSRETURN(1);
10506     }
10507   }
10508   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10509   Newx(outspec, VMS_MAXRSS, char);
10510   if (SvTYPE(mysv) == SVt_PVGV) {
10511     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10512       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10513       ST(0) = &PL_sv_no;
10514       Safefree(inspec);
10515       Safefree(outspec);
10516       XSRETURN(1);
10517     }
10518     outp = outspec;
10519   }
10520   else {
10521     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10522       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10523       ST(0) = &PL_sv_no;
10524       Safefree(inspec);
10525       Safefree(outspec);
10526       XSRETURN(1);
10527     }
10528   }
10529   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10530
10531   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10532   Safefree(inspec);
10533   Safefree(outspec);
10534   XSRETURN(1);
10535 }
10536
10537 /* The mod2fname is limited to shorter filenames by design, so it should
10538  * not be modified to support longer EFS pathnames
10539  */
10540 void
10541 mod2fname(pTHX_ CV *cv)
10542 {
10543   dXSARGS;
10544   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10545        workbuff[NAM$C_MAXRSS*1 + 1];
10546   int total_namelen = 3, counter, num_entries;
10547   /* ODS-5 ups this, but we want to be consistent, so... */
10548   int max_name_len = 39;
10549   AV *in_array = (AV *)SvRV(ST(0));
10550
10551   num_entries = av_len(in_array);
10552
10553   /* All the names start with PL_. */
10554   strcpy(ultimate_name, "PL_");
10555
10556   /* Clean up our working buffer */
10557   Zero(work_name, sizeof(work_name), char);
10558
10559   /* Run through the entries and build up a working name */
10560   for(counter = 0; counter <= num_entries; counter++) {
10561     /* If it's not the first name then tack on a __ */
10562     if (counter) {
10563       strcat(work_name, "__");
10564     }
10565     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10566                            PL_na));
10567   }
10568
10569   /* Check to see if we actually have to bother...*/
10570   if (strlen(work_name) + 3 <= max_name_len) {
10571     strcat(ultimate_name, work_name);
10572   } else {
10573     /* It's too darned big, so we need to go strip. We use the same */
10574     /* algorithm as xsubpp does. First, strip out doubled __ */
10575     char *source, *dest, last;
10576     dest = workbuff;
10577     last = 0;
10578     for (source = work_name; *source; source++) {
10579       if (last == *source && last == '_') {
10580         continue;
10581       }
10582       *dest++ = *source;
10583       last = *source;
10584     }
10585     /* Go put it back */
10586     strcpy(work_name, workbuff);
10587     /* Is it still too big? */
10588     if (strlen(work_name) + 3 > max_name_len) {
10589       /* Strip duplicate letters */
10590       last = 0;
10591       dest = workbuff;
10592       for (source = work_name; *source; source++) {
10593         if (last == toupper(*source)) {
10594         continue;
10595         }
10596         *dest++ = *source;
10597         last = toupper(*source);
10598       }
10599       strcpy(work_name, workbuff);
10600     }
10601
10602     /* Is it *still* too big? */
10603     if (strlen(work_name) + 3 > max_name_len) {
10604       /* Too bad, we truncate */
10605       work_name[max_name_len - 2] = 0;
10606     }
10607     strcat(ultimate_name, work_name);
10608   }
10609
10610   /* Okay, return it */
10611   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10612   XSRETURN(1);
10613 }
10614
10615 void
10616 hushexit_fromperl(pTHX_ CV *cv)
10617 {
10618     dXSARGS;
10619
10620     if (items > 0) {
10621         VMSISH_HUSHED = SvTRUE(ST(0));
10622     }
10623     ST(0) = boolSV(VMSISH_HUSHED);
10624     XSRETURN(1);
10625 }
10626
10627 #ifdef HAS_SYMLINK
10628 static char *
10629 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10630
10631 void
10632 vms_realpath_fromperl(pTHX_ CV *cv)
10633 {
10634   dXSARGS;
10635   char *fspec, *rslt_spec, *rslt;
10636   STRLEN n_a;
10637
10638   if (!items || items != 1)
10639     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10640
10641   fspec = SvPV(ST(0),n_a);
10642   if (!fspec || !*fspec) XSRETURN_UNDEF;
10643
10644   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10645   rslt = do_vms_realpath(fspec, rslt_spec);
10646   ST(0) = sv_newmortal();
10647   if (rslt != NULL)
10648     sv_usepvn(ST(0),rslt,strlen(rslt));
10649   else
10650     Safefree(rslt_spec);
10651   XSRETURN(1);
10652 }
10653 #endif
10654
10655 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10656 int do_vms_case_tolerant(void);
10657
10658 void
10659 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10660 {
10661   dXSARGS;
10662   ST(0) = boolSV(do_vms_case_tolerant());
10663   XSRETURN(1);
10664 }
10665 #endif
10666
10667 void
10668 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10669                           struct interp_intern *dst)
10670 {
10671     memcpy(dst,src,sizeof(struct interp_intern));
10672 }
10673
10674 void
10675 Perl_sys_intern_clear(pTHX)
10676 {
10677 }
10678
10679 void
10680 Perl_sys_intern_init(pTHX)
10681 {
10682     unsigned int ix = RAND_MAX;
10683     double x;
10684
10685     VMSISH_HUSHED = 0;
10686
10687     /* fix me later to track running under GNV */
10688     /* this allows some limited testing */
10689     MY_POSIX_EXIT = decc_filename_unix_report;
10690
10691     x = (float)ix;
10692     MY_INV_RAND_MAX = 1./x;
10693 }
10694
10695 void
10696 init_os_extras(void)
10697 {
10698   dTHX;
10699   char* file = __FILE__;
10700   char temp_buff[512];
10701   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10702     no_translate_barewords = TRUE;
10703   } else {
10704     no_translate_barewords = FALSE;
10705   }
10706
10707   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10708   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10709   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10710   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10711   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10712   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10713   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10714   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10715   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10716   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10717   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10718 #ifdef HAS_SYMLINK
10719   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10720 #endif
10721 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10722   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10723 #endif
10724
10725   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10726
10727   return;
10728 }
10729
10730 #ifdef HAS_SYMLINK
10731
10732 #if __CRTL_VER == 80200000
10733 /* This missed getting in to the DECC SDK for 8.2 */
10734 char *realpath(const char *file_name, char * resolved_name, ...);
10735 #endif
10736
10737 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10738 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10739  * The perl fallback routine to provide realpath() is not as efficient
10740  * on OpenVMS.
10741  */
10742 static char *
10743 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10744 {
10745     return realpath(filespec, outbuf);
10746 }
10747
10748 /*}}}*/
10749 /* External entry points */
10750 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10751 { return do_vms_realpath(filespec, outbuf); }
10752 #else
10753 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10754 { return NULL; }
10755 #endif
10756
10757
10758 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10759 /* case_tolerant */
10760
10761 /*{{{int do_vms_case_tolerant(void)*/
10762 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10763  * controlled by a process setting.
10764  */
10765 int do_vms_case_tolerant(void)
10766 {
10767     return vms_process_case_tolerant;
10768 }
10769 /*}}}*/
10770 /* External entry points */
10771 int Perl_vms_case_tolerant(void)
10772 { return do_vms_case_tolerant(); }
10773 #else
10774 int Perl_vms_case_tolerant(void)
10775 { return vms_process_case_tolerant; }
10776 #endif
10777
10778
10779  /* Start of DECC RTL Feature handling */
10780
10781 static int sys_trnlnm
10782    (const char * logname,
10783     char * value,
10784     int value_len)
10785 {
10786     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10787     const unsigned long attr = LNM$M_CASE_BLIND;
10788     struct dsc$descriptor_s name_dsc;
10789     int status;
10790     unsigned short result;
10791     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10792                                 {0, 0, 0, 0}};
10793
10794     name_dsc.dsc$w_length = strlen(logname);
10795     name_dsc.dsc$a_pointer = (char *)logname;
10796     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10797     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10798
10799     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10800
10801     if ($VMS_STATUS_SUCCESS(status)) {
10802
10803          /* Null terminate and return the string */
10804         /*--------------------------------------*/
10805         value[result] = 0;
10806     }
10807
10808     return status;
10809 }
10810
10811 static int sys_crelnm
10812    (const char * logname,
10813     const char * value)
10814 {
10815     int ret_val;
10816     const char * proc_table = "LNM$PROCESS_TABLE";
10817     struct dsc$descriptor_s proc_table_dsc;
10818     struct dsc$descriptor_s logname_dsc;
10819     struct itmlst_3 item_list[2];
10820
10821     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10822     proc_table_dsc.dsc$w_length = strlen(proc_table);
10823     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10824     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10825
10826     logname_dsc.dsc$a_pointer = (char *) logname;
10827     logname_dsc.dsc$w_length = strlen(logname);
10828     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10829     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10830
10831     item_list[0].buflen = strlen(value);
10832     item_list[0].itmcode = LNM$_STRING;
10833     item_list[0].bufadr = (char *)value;
10834     item_list[0].retlen = NULL;
10835
10836     item_list[1].buflen = 0;
10837     item_list[1].itmcode = 0;
10838
10839     ret_val = sys$crelnm
10840                        (NULL,
10841                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10842                         (const struct dsc$descriptor_s *)&logname_dsc,
10843                         NULL,
10844                         (const struct item_list_3 *) item_list);
10845
10846     return ret_val;
10847 }
10848
10849
10850 /* C RTL Feature settings */
10851
10852 static int set_features
10853    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10854     int (* cli_routine)(void),  /* Not documented */
10855     void *image_info)           /* Not documented */
10856 {
10857     int status;
10858     int s;
10859     int dflt;
10860     char* str;
10861     char val_str[10];
10862 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
10863     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10864     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10865     unsigned long case_perm;
10866     unsigned long case_image;
10867 #endif
10868
10869     /* hacks to see if known bugs are still present for testing */
10870
10871     /* Readdir is returning filenames in VMS syntax always */
10872     decc_bug_readdir_efs1 = 1;
10873     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10874     if ($VMS_STATUS_SUCCESS(status)) {
10875        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10876          decc_bug_readdir_efs1 = 1;
10877        else
10878          decc_bug_readdir_efs1 = 0;
10879     }
10880
10881     /* PCP mode requires creating /dev/null special device file */
10882     decc_bug_devnull = 1;
10883     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10884     if ($VMS_STATUS_SUCCESS(status)) {
10885        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10886           decc_bug_devnull = 1;
10887        else
10888           decc_bug_devnull = 0;
10889     }
10890
10891     /* fgetname returning a VMS name in UNIX mode */
10892     decc_bug_fgetname = 1;
10893     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10894     if ($VMS_STATUS_SUCCESS(status)) {
10895       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10896         decc_bug_fgetname = 1;
10897       else
10898         decc_bug_fgetname = 0;
10899     }
10900
10901     /* UNIX directory names with no paths are broken in a lot of places */
10902     decc_dir_barename = 1;
10903     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10904     if ($VMS_STATUS_SUCCESS(status)) {
10905       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10906         decc_dir_barename = 1;
10907       else
10908         decc_dir_barename = 0;
10909     }
10910
10911 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10912     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10913     if (s >= 0) {
10914         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10915         if (decc_disable_to_vms_logname_translation < 0)
10916             decc_disable_to_vms_logname_translation = 0;
10917     }
10918
10919     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10920     if (s >= 0) {
10921         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10922         if (decc_efs_case_preserve < 0)
10923             decc_efs_case_preserve = 0;
10924     }
10925
10926     s = decc$feature_get_index("DECC$EFS_CHARSET");
10927     if (s >= 0) {
10928         decc_efs_charset = decc$feature_get_value(s, 1);
10929         if (decc_efs_charset < 0)
10930             decc_efs_charset = 0;
10931     }
10932
10933     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10934     if (s >= 0) {
10935         decc_filename_unix_report = decc$feature_get_value(s, 1);
10936         if (decc_filename_unix_report > 0)
10937             decc_filename_unix_report = 1;
10938         else
10939             decc_filename_unix_report = 0;
10940     }
10941
10942     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10943     if (s >= 0) {
10944         decc_filename_unix_only = decc$feature_get_value(s, 1);
10945         if (decc_filename_unix_only > 0) {
10946             decc_filename_unix_only = 1;
10947         }
10948         else {
10949             decc_filename_unix_only = 0;
10950         }
10951     }
10952
10953     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10954     if (s >= 0) {
10955         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10956         if (decc_filename_unix_no_version < 0)
10957             decc_filename_unix_no_version = 0;
10958     }
10959
10960     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10961     if (s >= 0) {
10962         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10963         if (decc_readdir_dropdotnotype < 0)
10964             decc_readdir_dropdotnotype = 0;
10965     }
10966
10967     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10968     if ($VMS_STATUS_SUCCESS(status)) {
10969         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10970         if (s >= 0) {
10971             dflt = decc$feature_get_value(s, 4);
10972             if (dflt > 0) {
10973                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10974                 if (decc_disable_posix_root <= 0) {
10975                     decc$feature_set_value(s, 1, 1);
10976                     decc_disable_posix_root = 1;
10977                 }
10978             }
10979             else {
10980                 /* Traditionally Perl assumes this is off */
10981                 decc_disable_posix_root = 1;
10982                 decc$feature_set_value(s, 1, 1);
10983             }
10984         }
10985     }
10986
10987 #if __CRTL_VER >= 80200000
10988     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10989     if (s >= 0) {
10990         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10991         if (decc_posix_compliant_pathnames < 0)
10992             decc_posix_compliant_pathnames = 0;
10993         if (decc_posix_compliant_pathnames > 4)
10994             decc_posix_compliant_pathnames = 0;
10995     }
10996
10997 #endif
10998 #else
10999     status = sys_trnlnm
11000         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11001     if ($VMS_STATUS_SUCCESS(status)) {
11002         val_str[0] = _toupper(val_str[0]);
11003         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11004            decc_disable_to_vms_logname_translation = 1;
11005         }
11006     }
11007
11008 #ifndef __VAX
11009     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11010     if ($VMS_STATUS_SUCCESS(status)) {
11011         val_str[0] = _toupper(val_str[0]);
11012         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11013            decc_efs_case_preserve = 1;
11014         }
11015     }
11016 #endif
11017
11018     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11019     if ($VMS_STATUS_SUCCESS(status)) {
11020         val_str[0] = _toupper(val_str[0]);
11021         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11022            decc_filename_unix_report = 1;
11023         }
11024     }
11025     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11026     if ($VMS_STATUS_SUCCESS(status)) {
11027         val_str[0] = _toupper(val_str[0]);
11028         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11029            decc_filename_unix_only = 1;
11030            decc_filename_unix_report = 1;
11031         }
11032     }
11033     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11034     if ($VMS_STATUS_SUCCESS(status)) {
11035         val_str[0] = _toupper(val_str[0]);
11036         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11037            decc_filename_unix_no_version = 1;
11038         }
11039     }
11040     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11041     if ($VMS_STATUS_SUCCESS(status)) {
11042         val_str[0] = _toupper(val_str[0]);
11043         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11044            decc_readdir_dropdotnotype = 1;
11045         }
11046     }
11047 #endif
11048
11049 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11050
11051      /* Report true case tolerance */
11052     /*----------------------------*/
11053     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11054     if (!$VMS_STATUS_SUCCESS(status))
11055         case_perm = PPROP$K_CASE_BLIND;
11056     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11057     if (!$VMS_STATUS_SUCCESS(status))
11058         case_image = PPROP$K_CASE_BLIND;
11059     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11060         (case_image == PPROP$K_CASE_SENSITIVE))
11061         vms_process_case_tolerant = 0;
11062
11063 #endif
11064
11065
11066     /* CRTL can be initialized past this point, but not before. */
11067 /*    DECC$CRTL_INIT(); */
11068
11069     return SS$_NORMAL;
11070 }
11071
11072 #ifdef __DECC
11073 /* DECC dependent attributes */
11074 #if __DECC_VER < 60560002
11075 #define relative
11076 #define not_executable
11077 #else
11078 #define relative ,rel
11079 #define not_executable ,noexe
11080 #endif
11081 #pragma nostandard
11082 #pragma extern_model save
11083 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11084 #endif
11085         const __align (LONGWORD) int spare[8] = {0};
11086 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11087 /*                        NOWRT, LONG */
11088 #ifdef __DECC
11089 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11090         nowrt,noshr relative not_executable
11091 #endif
11092 const long vms_cc_features = (const long)set_features;
11093
11094 /*
11095 ** Force a reference to LIB$INITIALIZE to ensure it
11096 ** exists in the image.
11097 */
11098 int lib$initialize(void);
11099 #ifdef __DECC
11100 #pragma extern_model strict_refdef
11101 #endif
11102     int lib_init_ref = (int) lib$initialize;
11103
11104 #ifdef __DECC
11105 #pragma extern_model restore
11106 #pragma standard
11107 #endif
11108
11109 /*  End of vms.c */