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 static int vms_debug_on_exception = 0;
 254
 255 /* Is this a UNIX file specification?
 256  *   No longer a simple check with EFS file specs
 257  *   For now, not a full check, but need to
 258  *   handle POSIX ^UP^ specifications
 259  *   Fixing to handle ^/ cases would require
 260  *   changes to many other conversion routines.
 261  */
 262
 263 static is_unix_filespec(const char *path)
 264 {
 265 int ret_val;
 266 const char * pch1;
 267
 268     ret_val = 0;
 269     if (strncmp(path,"\"^UP^",5) != 0) {
 270         pch1 = strchr(path, '/');
 271         if (pch1 != NULL)
 272             ret_val = 1;
 273         else {
 274
 275             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 276             if (decc_filename_unix_report || decc_filename_unix_only) {
 277             if (strcmp(path,".") == 0)
 278                 ret_val = 1;
 279             }
 280         }
 281     }
 282     return ret_val;
 283 }
 284
 285
 286 /* my_maxidx
 287  * Routine to retrieve the maximum equivalence index for an input
 288  * logical name.  Some calls to this routine have no knowledge if
 289  * the variable is a logical or not.  So on error we return a max
 290  * index of zero.
 291  */
 292 /*{{{int my_maxidx(const char *lnm) */
 293 static int
 294 my_maxidx(const char *lnm)
 295 {
 296     int status;
 297     int midx;
 298     int attr = LNM$M_CASE_BLIND;
 299     struct dsc$descriptor lnmdsc;
 300     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 301                                 {0, 0, 0, 0}};
 302
 303     lnmdsc.dsc$w_length = strlen(lnm);
 304     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 305     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 306     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 307
 308     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 309     if ((status & 1) == 0)
 310        midx = 0;
 311
 312     return (midx);
 313 }
 314 /*}}}*/
 315
 316 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 317 int
 318 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 319   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 320 {
 321     const char *cp1;
 322     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 323     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 324     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 325     int midx;
 326     unsigned char acmode;
 327     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 328                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 329     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 330                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 331                                  {0, 0, 0, 0}};
 332     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 333 #if defined(PERL_IMPLICIT_CONTEXT)
 334     pTHX = NULL;
 335     if (PL_curinterp) {
 336       aTHX = PERL_GET_INTERP;
 337     } else {
 338       aTHX = NULL;
 339     }
 340 #endif
 341
 342     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 343       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 344     }
 345     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 346       *cp2 = _toupper(*cp1);
 347       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 348         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 349         return 0;
 350       }
 351     }
 352     lnmdsc.dsc$w_length = cp1 - lnm;
 353     lnmdsc.dsc$a_pointer = uplnm;
 354     uplnm[lnmdsc.dsc$w_length] = '\0';
 355     secure = flags & PERL__TRNENV_SECURE;
 356     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 357     if (!tabvec || !*tabvec) tabvec = env_tables;
 358
 359     for (curtab = 0; tabvec[curtab]; curtab++) {
 360       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 361         if (!ivenv && !secure) {
 362           char *eq, *end;
 363           int i;
 364           if (!environ) {
 365             ivenv = 1;
 366             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 367             continue;
 368           }
 369           retsts = SS$_NOLOGNAM;
 370           for (i = 0; environ[i]; i++) {
 371             if ((eq = strchr(environ[i],'=')) &&
 372                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 373                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 374               eq++;
 375               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 376               if (!eqvlen) continue;
 377               retsts = SS$_NORMAL;
 378               break;
 379             }
 380           }
 381           if (retsts != SS$_NOLOGNAM) break;
 382         }
 383       }
 384       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 385                !str$case_blind_compare(&tmpdsc,&clisym)) {
 386         if (!ivsym && !secure) {
 387           unsigned short int deflen = LNM$C_NAMLENGTH;
 388           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 389           /* dynamic dsc to accomodate possible long value */
 390           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 391           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 392           if (retsts & 1) {
 393             if (eqvlen > MAX_DCL_SYMBOL) {
 394               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 395               eqvlen = MAX_DCL_SYMBOL;
 396               /* Special hack--we might be called before the interpreter's */
 397               /* fully initialized, in which case either thr or PL_curcop */
 398               /* might be bogus. We have to check, since ckWARN needs them */
 399               /* both to be valid if running threaded */
 400                 if (ckWARN(WARN_MISC)) {
 401                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 402                 }
 403             }
 404             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 405           }
 406           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 407           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 408           if (retsts == LIB$_NOSUCHSYM) continue;
 409           break;
 410         }
 411       }
 412       else if (!ivlnm) {
 413         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 414           midx = my_maxidx(lnm);
 415           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 416             lnmlst[1].bufadr = cp2;
 417             eqvlen = 0;
 418             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 419             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 420             if (retsts == SS$_NOLOGNAM) break;
 421             /* PPFs have a prefix */
 422             if (
 423 #if INTSIZE == 4
 424                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 425 #endif
 426                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 427                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 428                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 429                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 430                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 431               memmove(eqv,eqv+4,eqvlen-4);
 432               eqvlen -= 4;
 433             }
 434             cp2 += eqvlen;
 435             *cp2 = '\0';
 436           }
 437           if ((retsts == SS$_IVLOGNAM) ||
 438               (retsts == SS$_NOLOGNAM)) { continue; }
 439         }
 440         else {
 441           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 442           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 443           if (retsts == SS$_NOLOGNAM) continue;
 444           eqv[eqvlen] = '\0';
 445         }
 446         eqvlen = strlen(eqv);
 447         break;
 448       }
 449     }
 450     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 451     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 452              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 453              retsts == SS$_NOLOGNAM) {
 454       set_errno(EINVAL);  set_vaxc_errno(retsts);
 455     }
 456     else _ckvmssts(retsts);
 457     return 0;
 458 }  /* end of vmstrnenv */
 459 /*}}}*/
 460
 461 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 462 /* Define as a function so we can access statics. */
 463 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 464 {
 465   return vmstrnenv(lnm,eqv,idx,fildev,
 466 #ifdef SECURE_INTERNAL_GETENV
 467                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 468 #else
 469                    0
 470 #endif
 471                                                                               );
 472 }
 473 /*}}}*/
 474
 475 /* my_getenv
 476  * Note: Uses Perl temp to store result so char * can be returned to
 477  * caller; this pointer will be invalidated at next Perl statement
 478  * transition.
 479  * We define this as a function rather than a macro in terms of my_getenv_len()
 480  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 481  * allocate SVs).
 482  */
 483 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 484 char *
 485 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 486 {
 487     const char *cp1;
 488     static char *__my_getenv_eqv = NULL;
 489     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 490     unsigned long int idx = 0;
 491     int trnsuccess, success, secure, saverr, savvmserr;
 492     int midx, flags;
 493     SV *tmpsv;
 494
 495     midx = my_maxidx(lnm) + 1;
 496
 497     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 498       /* Set up a temporary buffer for the return value; Perl will
 499        * clean it up at the next statement transition */
 500       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 501       if (!tmpsv) return NULL;
 502       eqv = SvPVX(tmpsv);
 503     }
 504     else {
 505       /* Assume no interpreter ==> single thread */
 506       if (__my_getenv_eqv != NULL) {
 507         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 508       }
 509       else {
 510         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 511       }
 512       eqv = __my_getenv_eqv;
 513     }
 514
 515     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 516     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 517       int len;
 518       getcwd(eqv,LNM$C_NAMLENGTH);
 519
 520       len = strlen(eqv);
 521
 522       /* Get rid of "000000/ in rooted filespecs */
 523       if (len > 7) {
 524         char * zeros;
 525         zeros = strstr(eqv, "/000000/");
 526         if (zeros != NULL) {
 527           int mlen;
 528           mlen = len - (zeros - eqv) - 7;
 529           memmove(zeros, &zeros[7], mlen);
 530           len = len - 7;
 531           eqv[len] = '\0';
 532         }
 533       }
 534       return eqv;
 535     }
 536     else {
 537       /* Impose security constraints only if tainting */
 538       if (sys) {
 539         /* Impose security constraints only if tainting */
 540         secure = PL_curinterp ? PL_tainting : will_taint;
 541         saverr = errno;  savvmserr = vaxc$errno;
 542       }
 543       else {
 544         secure = 0;
 545       }
 546
 547       flags =
 548 #ifdef SECURE_INTERNAL_GETENV
 549               secure ? PERL__TRNENV_SECURE : 0
 550 #else
 551               0
 552 #endif
 553       ;
 554
 555       /* For the getenv interface we combine all the equivalence names
 556        * of a search list logical into one value to acquire a maximum
 557        * value length of 255*128 (assuming %ENV is using logicals).
 558        */
 559       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 560
 561       /* If the name contains a semicolon-delimited index, parse it
 562        * off and make sure we only retrieve the equivalence name for
 563        * that index.  */
 564       if ((cp2 = strchr(lnm,';')) != NULL) {
 565         strcpy(uplnm,lnm);
 566         uplnm[cp2-lnm] = '\0';
 567         idx = strtoul(cp2+1,NULL,0);
 568         lnm = uplnm;
 569         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 570       }
 571
 572       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 573
 574       /* Discard NOLOGNAM on internal calls since we're often looking
 575        * for an optional name, and this "error" often shows up as the
 576        * (bogus) exit status for a die() call later on.  */
 577       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 578       return success ? eqv : Nullch;
 579     }
 580
 581 }  /* end of my_getenv() */
 582 /*}}}*/
 583
 584
 585 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 586 char *
 587 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 588 {
 589     const char *cp1;
 590     char *buf, *cp2;
 591     unsigned long idx = 0;
 592     int midx, flags;
 593     static char *__my_getenv_len_eqv = NULL;
 594     int secure, saverr, savvmserr;
 595     SV *tmpsv;
 596
 597     midx = my_maxidx(lnm) + 1;
 598
 599     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 600       /* Set up a temporary buffer for the return value; Perl will
 601        * clean it up at the next statement transition */
 602       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 603       if (!tmpsv) return NULL;
 604       buf = SvPVX(tmpsv);
 605     }
 606     else {
 607       /* Assume no interpreter ==> single thread */
 608       if (__my_getenv_len_eqv != NULL) {
 609         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 610       }
 611       else {
 612         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 613       }
 614       buf = __my_getenv_len_eqv;
 615     }
 616
 617     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 618     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 619     char * zeros;
 620
 621       getcwd(buf,LNM$C_NAMLENGTH);
 622       *len = strlen(buf);
 623
 624       /* Get rid of "000000/ in rooted filespecs */
 625       if (*len > 7) {
 626       zeros = strstr(buf, "/000000/");
 627       if (zeros != NULL) {
 628         int mlen;
 629         mlen = *len - (zeros - buf) - 7;
 630         memmove(zeros, &zeros[7], mlen);
 631         *len = *len - 7;
 632         buf[*len] = '\0';
 633         }
 634       }
 635       return buf;
 636     }
 637     else {
 638       if (sys) {
 639         /* Impose security constraints only if tainting */
 640         secure = PL_curinterp ? PL_tainting : will_taint;
 641         saverr = errno;  savvmserr = vaxc$errno;
 642       }
 643       else {
 644         secure = 0;
 645       }
 646
 647       flags =
 648 #ifdef SECURE_INTERNAL_GETENV
 649               secure ? PERL__TRNENV_SECURE : 0
 650 #else
 651               0
 652 #endif
 653       ;
 654
 655       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 656
 657       if ((cp2 = strchr(lnm,';')) != NULL) {
 658         strcpy(buf,lnm);
 659         buf[cp2-lnm] = '\0';
 660         idx = strtoul(cp2+1,NULL,0);
 661         lnm = buf;
 662         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 663       }
 664
 665       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 666
 667       /* Get rid of "000000/ in rooted filespecs */
 668       if (*len > 7) {
 669       char * zeros;
 670         zeros = strstr(buf, "/000000/");
 671         if (zeros != NULL) {
 672           int mlen;
 673           mlen = *len - (zeros - buf) - 7;
 674           memmove(zeros, &zeros[7], mlen);
 675           *len = *len - 7;
 676           buf[*len] = '\0';
 677         }
 678       }
 679
 680       /* Discard NOLOGNAM on internal calls since we're often looking
 681        * for an optional name, and this "error" often shows up as the
 682        * (bogus) exit status for a die() call later on.  */
 683       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 684       return *len ? buf : Nullch;
 685     }
 686
 687 }  /* end of my_getenv_len() */
 688 /*}}}*/
 689
 690 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 691
 692 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 693
 694 /*{{{ void prime_env_iter() */
 695 void
 696 prime_env_iter(void)
 697 /* Fill the %ENV associative array with all logical names we can
 698  * find, in preparation for iterating over it.
 699  */
 700 {
 701   static int primed = 0;
 702   HV *seenhv = NULL, *envhv;
 703   SV *sv = NULL;
 704   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 705   unsigned short int chan;
 706 #ifndef CLI$M_TRUSTED
 707 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 708 #endif
 709   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 710   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 711   long int i;
 712   bool have_sym = FALSE, have_lnm = FALSE;
 713   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 714   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 715   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 716   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 717   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 718 #if defined(PERL_IMPLICIT_CONTEXT)
 719   pTHX;
 720 #endif
 721 #if defined(USE_ITHREADS)
 722   static perl_mutex primenv_mutex;
 723   MUTEX_INIT(&primenv_mutex);
 724 #endif
 725
 726 #if defined(PERL_IMPLICIT_CONTEXT)
 727     /* We jump through these hoops because we can be called at */
 728     /* platform-specific initialization time, which is before anything is */
 729     /* set up--we can't even do a plain dTHX since that relies on the */
 730     /* interpreter structure to be initialized */
 731     if (PL_curinterp) {
 732       aTHX = PERL_GET_INTERP;
 733     } else {
 734       aTHX = NULL;
 735     }
 736 #endif
 737
 738   if (primed || !PL_envgv) return;
 739   MUTEX_LOCK(&primenv_mutex);
 740   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 741   envhv = GvHVn(PL_envgv);
 742   /* Perform a dummy fetch as an lval to insure that the hash table is
 743    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 744   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 745
 746   for (i = 0; env_tables[i]; i++) {
 747      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 748          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 749      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 750   }
 751   if (have_sym || have_lnm) {
 752     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 753     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 754     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 755     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 756   }
 757
 758   for (i--; i >= 0; i--) {
 759     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 760       char *start;
 761       int j;
 762       for (j = 0; environ[j]; j++) {
 763         if (!(start = strchr(environ[j],'='))) {
 764           if (ckWARN(WARN_INTERNAL))
 765             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 766         }
 767         else {
 768           start++;
 769           sv = newSVpv(start,0);
 770           SvTAINTED_on(sv);
 771           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 772         }
 773       }
 774       continue;
 775     }
 776     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 777              !str$case_blind_compare(&tmpdsc,&clisym)) {
 778       strcpy(cmd,"Show Symbol/Global *");
 779       cmddsc.dsc$w_length = 20;
 780       if (env_tables[i]->dsc$w_length == 12 &&
 781           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 782           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 783       flags = defflags | CLI$M_NOLOGNAM;
 784     }
 785     else {
 786       strcpy(cmd,"Show Logical *");
 787       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 788         strcat(cmd," /Table=");
 789         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 790         cmddsc.dsc$w_length = strlen(cmd);
 791       }
 792       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 793       flags = defflags | CLI$M_NOCLISYM;
 794     }
 795
 796     /* Create a new subprocess to execute each command, to exclude the
 797      * remote possibility that someone could subvert a mbx or file used
 798      * to write multiple commands to a single subprocess.
 799      */
 800     do {
 801       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 802                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 803       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 804       defflags &= ~CLI$M_TRUSTED;
 805     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 806     _ckvmssts(retsts);
 807     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 808     if (seenhv) SvREFCNT_dec(seenhv);
 809     seenhv = newHV();
 810     while (1) {
 811       char *cp1, *cp2, *key;
 812       unsigned long int sts, iosb[2], retlen, keylen;
 813       register U32 hash;
 814
 815       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 816       if (sts & 1) sts = iosb[0] & 0xffff;
 817       if (sts == SS$_ENDOFFILE) {
 818         int wakect = 0;
 819         while (substs == 0) { sys$hiber(); wakect++;}
 820         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 821         _ckvmssts(substs);
 822         break;
 823       }
 824       _ckvmssts(sts);
 825       retlen = iosb[0] >> 16;
 826       if (!retlen) continue;  /* blank line */
 827       buf[retlen] = '\0';
 828       if (iosb[1] != subpid) {
 829         if (iosb[1]) {
 830           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 831         }
 832         continue;
 833       }
 834       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 835         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 836
 837       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 838       if (*cp1 == '(' || /* Logical name table name */
 839           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 840       if (*cp1 == '"') cp1++;
 841       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 842       key = cp1;  keylen = cp2 - cp1;
 843       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 844       while (*cp2 && *cp2 != '=') cp2++;
 845       while (*cp2 && *cp2 == '=') cp2++;
 846       while (*cp2 && *cp2 == ' ') cp2++;
 847       if (*cp2 == '"') {  /* String translation; may embed "" */
 848         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 849         cp2++;  cp1--; /* Skip "" surrounding translation */
 850       }
 851       else {  /* Numeric translation */
 852         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 853         cp1--;  /* stop on last non-space char */
 854       }
 855       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 856         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 857         continue;
 858       }
 859       PERL_HASH(hash,key,keylen);
 860
 861       if (cp1 == cp2 && *cp2 == '.') {
 862         /* A single dot usually means an unprintable character, such as a null
 863          * to indicate a zero-length value.  Get the actual value to make sure.
 864          */
 865         char lnm[LNM$C_NAMLENGTH+1];
 866         char eqv[MAX_DCL_SYMBOL+1];
 867         strncpy(lnm, key, keylen);
 868         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 869         sv = newSVpvn(eqv, strlen(eqv));
 870       }
 871       else {
 872         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 873       }
 874
 875       SvTAINTED_on(sv);
 876       hv_store(envhv,key,keylen,sv,hash);
 877       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 878     }
 879     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 880       /* get the PPFs for this process, not the subprocess */
 881       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 882       char eqv[LNM$C_NAMLENGTH+1];
 883       int trnlen, i;
 884       for (i = 0; ppfs[i]; i++) {
 885         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 886         sv = newSVpv(eqv,trnlen);
 887         SvTAINTED_on(sv);
 888         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 889       }
 890     }
 891   }
 892   primed = 1;
 893   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 894   if (buf) Safefree(buf);
 895   if (seenhv) SvREFCNT_dec(seenhv);
 896   MUTEX_UNLOCK(&primenv_mutex);
 897   return;
 898
 899 }  /* end of prime_env_iter */
 900 /*}}}*/
 901
 902
 903 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 904 /* Define or delete an element in the same "environment" as
 905  * vmstrnenv().  If an element is to be deleted, it's removed from
 906  * the first place it's found.  If it's to be set, it's set in the
 907  * place designated by the first element of the table vector.
 908  * Like setenv() returns 0 for success, non-zero on error.
 909  */
 910 int
 911 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 912 {
 913     const char *cp1;
 914     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 915     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 916     int nseg = 0, j;
 917     unsigned long int retsts, usermode = PSL$C_USER;
 918     struct itmlst_3 *ile, *ilist;
 919     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 920                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 921                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 922     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 923     $DESCRIPTOR(local,"_LOCAL");
 924
 925     if (!lnm) {
 926         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 927         return SS$_IVLOGNAM;
 928     }
 929
 930     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 931       *cp2 = _toupper(*cp1);
 932       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 933         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 934         return SS$_IVLOGNAM;
 935       }
 936     }
 937     lnmdsc.dsc$w_length = cp1 - lnm;
 938     if (!tabvec || !*tabvec) tabvec = env_tables;
 939
 940     if (!eqv) {  /* we're deleting n element */
 941       for (curtab = 0; tabvec[curtab]; curtab++) {
 942         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 943         int i;
 944           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 945             if ((cp1 = strchr(environ[i],'=')) &&
 946                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 947                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 948 #ifdef HAS_SETENV
 949               return setenv(lnm,"",1) ? vaxc$errno : 0;
 950             }
 951           }
 952           ivenv = 1; retsts = SS$_NOLOGNAM;
 953 #else
 954               if (ckWARN(WARN_INTERNAL))
 955                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 956               ivenv = 1; retsts = SS$_NOSUCHPGM;
 957               break;
 958             }
 959           }
 960 #endif
 961         }
 962         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 963                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 964           unsigned int symtype;
 965           if (tabvec[curtab]->dsc$w_length == 12 &&
 966               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 967               !str$case_blind_compare(&tmpdsc,&local))
 968             symtype = LIB$K_CLI_LOCAL_SYM;
 969           else symtype = LIB$K_CLI_GLOBAL_SYM;
 970           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 971           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 972           if (retsts == LIB$_NOSUCHSYM) continue;
 973           break;
 974         }
 975         else if (!ivlnm) {
 976           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 977           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 978           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 979           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 980           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 981         }
 982       }
 983     }
 984     else {  /* we're defining a value */
 985       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 986 #ifdef HAS_SETENV
 987         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 988 #else
 989         if (ckWARN(WARN_INTERNAL))
 990           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 991         retsts = SS$_NOSUCHPGM;
 992 #endif
 993       }
 994       else {
 995         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 996         eqvdsc.dsc$w_length  = strlen(eqv);
 997         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 998             !str$case_blind_compare(&tmpdsc,&clisym)) {
 999           unsigned int symtype;
1000           if (tabvec[0]->dsc$w_length == 12 &&
1001               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1002                !str$case_blind_compare(&tmpdsc,&local))
1003             symtype = LIB$K_CLI_LOCAL_SYM;
1004           else symtype = LIB$K_CLI_GLOBAL_SYM;
1005           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1006         }
1007         else {
1008           if (!*eqv) eqvdsc.dsc$w_length = 1;
1009           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1010
1011             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1012             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1013               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1014                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1015               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1016               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1017             }
1018
1019             Newx(ilist,nseg+1,struct itmlst_3);
1020             ile = ilist;
1021             if (!ile) {
1022               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1023               return SS$_INSFMEM;
1024             }
1025             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1026
1027             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1028               ile->itmcode = LNM$_STRING;
1029               ile->bufadr = c;
1030               if ((j+1) == nseg) {
1031                 ile->buflen = strlen(c);
1032                 /* in case we are truncating one that's too long */
1033                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1034               }
1035               else {
1036                 ile->buflen = LNM$C_NAMLENGTH;
1037               }
1038             }
1039
1040             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1041             Safefree (ilist);
1042           }
1043           else {
1044             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1045           }
1046         }
1047       }
1048     }
1049     if (!(retsts & 1)) {
1050       switch (retsts) {
1051         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1052         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1053           set_errno(EVMSERR); break;
1054         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1055         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1056           set_errno(EINVAL); break;
1057         case SS$_NOPRIV:
1058           set_errno(EACCES);
1059         default:
1060           _ckvmssts(retsts);
1061           set_errno(EVMSERR);
1062        }
1063        set_vaxc_errno(retsts);
1064        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1065     }
1066     else {
1067       /* We reset error values on success because Perl does an hv_fetch()
1068        * before each hv_store(), and if the thing we're setting didn't
1069        * previously exist, we've got a leftover error message.  (Of course,
1070        * this fails in the face of
1071        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1072        * in that the error reported in $! isn't spurious,
1073        * but it's right more often than not.)
1074        */
1075       set_errno(0); set_vaxc_errno(retsts);
1076       return 0;
1077     }
1078
1079 }  /* end of vmssetenv() */
1080 /*}}}*/
1081
1082 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1083 /* This has to be a function since there's a prototype for it in proto.h */
1084 void
1085 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1086 {
1087     if (lnm && *lnm) {
1088       int len = strlen(lnm);
1089       if  (len == 7) {
1090         char uplnm[8];
1091         int i;
1092         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1093         if (!strcmp(uplnm,"DEFAULT")) {
1094           if (eqv && *eqv) my_chdir(eqv);
1095           return;
1096         }
1097     }
1098 #ifndef RTL_USES_UTC
1099     if (len == 6 || len == 2) {
1100       char uplnm[7];
1101       int i;
1102       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1103       uplnm[len] = '\0';
1104       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1105       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1106     }
1107 #endif
1108   }
1109   (void) vmssetenv(lnm,eqv,NULL);
1110 }
1111 /*}}}*/
1112
1113 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1114 /*  vmssetuserlnm
1115  *  sets a user-mode logical in the process logical name table
1116  *  used for redirection of sys$error
1117  */
1118 void
1119 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1120 {
1121     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1122     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1123     unsigned long int iss, attr = LNM$M_CONFINE;
1124     unsigned char acmode = PSL$C_USER;
1125     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1126                                  {0, 0, 0, 0}};
1127     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1128     d_name.dsc$w_length = strlen(name);
1129
1130     lnmlst[0].buflen = strlen(eqv);
1131     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1132
1133     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1134     if (!(iss&1)) lib$signal(iss);
1135 }
1136 /*}}}*/
1137
1138
1139 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1140 /* my_crypt - VMS password hashing
1141  * my_crypt() provides an interface compatible with the Unix crypt()
1142  * C library function, and uses sys$hash_password() to perform VMS
1143  * password hashing.  The quadword hashed password value is returned
1144  * as a NUL-terminated 8 character string.  my_crypt() does not change
1145  * the case of its string arguments; in order to match the behavior
1146  * of LOGINOUT et al., alphabetic characters in both arguments must
1147  *  be upcased by the caller.
1148  *
1149  * - fix me to call ACM services when available
1150  */
1151 char *
1152 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1153 {
1154 #   ifndef UAI$C_PREFERRED_ALGORITHM
1155 #     define UAI$C_PREFERRED_ALGORITHM 127
1156 #   endif
1157     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1158     unsigned short int salt = 0;
1159     unsigned long int sts;
1160     struct const_dsc {
1161         unsigned short int dsc$w_length;
1162         unsigned char      dsc$b_type;
1163         unsigned char      dsc$b_class;
1164         const char *       dsc$a_pointer;
1165     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1166        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1167     struct itmlst_3 uailst[3] = {
1168         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1169         { sizeof salt, UAI$_SALT,    &salt, 0},
1170         { 0,           0,            NULL,  NULL}};
1171     static char hash[9];
1172
1173     usrdsc.dsc$w_length = strlen(usrname);
1174     usrdsc.dsc$a_pointer = usrname;
1175     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1176       switch (sts) {
1177         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1178           set_errno(EACCES);
1179           break;
1180         case RMS$_RNF:
1181           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1182           break;
1183         default:
1184           set_errno(EVMSERR);
1185       }
1186       set_vaxc_errno(sts);
1187       if (sts != RMS$_RNF) return NULL;
1188     }
1189
1190     txtdsc.dsc$w_length = strlen(textpasswd);
1191     txtdsc.dsc$a_pointer = textpasswd;
1192     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1193       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1194     }
1195
1196     return (char *) hash;
1197
1198 }  /* end of my_crypt() */
1199 /*}}}*/
1200
1201
1202 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1203 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1204 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1205
1206 /* fixup barenames that are directories for internal use.
1207  * There have been problems with the consistent handling of UNIX
1208  * style directory names when routines are presented with a name that
1209  * has no directory delimitors at all.  So this routine will eventually
1210  * fix the issue.
1211  */
1212 static char * fixup_bare_dirnames(const char * name)
1213 {
1214   if (decc_disable_to_vms_logname_translation) {
1215 /* fix me */
1216   }
1217   return NULL;
1218 }
1219
1220 /* mp_do_kill_file
1221  * A little hack to get around a bug in some implemenation of remove()
1222  * that do not know how to delete a directory
1223  *
1224  * Delete any file to which user has control access, regardless of whether
1225  * delete access is explicitly allowed.
1226  * Limitations: User must have write access to parent directory.
1227  *              Does not block signals or ASTs; if interrupted in midstream
1228  *              may leave file with an altered ACL.
1229  * HANDLE WITH CARE!
1230  */
1231 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1232 static int
1233 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1234 {
1235     char *vmsname, *rspec;
1236     char *remove_name;
1237     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1238     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1239     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1240     struct myacedef {
1241       unsigned char myace$b_length;
1242       unsigned char myace$b_type;
1243       unsigned short int myace$w_flags;
1244       unsigned long int myace$l_access;
1245       unsigned long int myace$l_ident;
1246     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1247                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1248       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1249      struct itmlst_3
1250        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1251                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1252        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1253        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1254        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1255        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1256
1257     /* Expand the input spec using RMS, since the CRTL remove() and
1258      * system services won't do this by themselves, so we may miss
1259      * a file "hiding" behind a logical name or search list. */
1260     Newx(vmsname, NAM$C_MAXRSS+1, char);
1261     if (do_tovmsspec(name,vmsname,0) == NULL) {
1262       Safefree(vmsname);
1263       return -1;
1264     }
1265
1266     if (decc_posix_compliant_pathnames) {
1267       /* In POSIX mode, we prefer to remove the UNIX name */
1268       rspec = vmsname;
1269       remove_name = (char *)name;
1270     }
1271     else {
1272       Newx(rspec, NAM$C_MAXRSS+1, char);
1273       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1274         Safefree(rspec);
1275         Safefree(vmsname);
1276         return -1;
1277       }
1278       Safefree(vmsname);
1279       remove_name = rspec;
1280     }
1281
1282 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1283     if (dirflag != 0) {
1284         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1285           Newx(remove_name, NAM$C_MAXRSS+1, char);
1286           do_pathify_dirspec(name, remove_name, 0);
1287           if (!rmdir(remove_name)) {
1288
1289             Safefree(remove_name);
1290             Safefree(rspec);
1291             return 0;   /* Can we just get rid of it? */
1292           }
1293         }
1294         else {
1295           if (!rmdir(remove_name)) {
1296             Safefree(rspec);
1297             return 0;   /* Can we just get rid of it? */
1298           }
1299         }
1300     }
1301     else
1302 #endif
1303       if (!remove(remove_name)) {
1304         Safefree(rspec);
1305         return 0;   /* Can we just get rid of it? */
1306       }
1307
1308     /* If not, can changing protections help? */
1309     if (vaxc$errno != RMS$_PRV) {
1310       Safefree(rspec);
1311       return -1;
1312     }
1313
1314     /* No, so we get our own UIC to use as a rights identifier,
1315      * and the insert an ACE at the head of the ACL which allows us
1316      * to delete the file.
1317      */
1318     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1319     fildsc.dsc$w_length = strlen(rspec);
1320     fildsc.dsc$a_pointer = rspec;
1321     cxt = 0;
1322     newace.myace$l_ident = oldace.myace$l_ident;
1323     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1324       switch (aclsts) {
1325         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1326           set_errno(ENOENT); break;
1327         case RMS$_DIR:
1328           set_errno(ENOTDIR); break;
1329         case RMS$_DEV:
1330           set_errno(ENODEV); break;
1331         case RMS$_SYN: case SS$_INVFILFOROP:
1332           set_errno(EINVAL); break;
1333         case RMS$_PRV:
1334           set_errno(EACCES); break;
1335         default:
1336           _ckvmssts(aclsts);
1337       }
1338       set_vaxc_errno(aclsts);
1339       Safefree(rspec);
1340       return -1;
1341     }
1342     /* Grab any existing ACEs with this identifier in case we fail */
1343     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1344     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1345                     || fndsts == SS$_NOMOREACE ) {
1346       /* Add the new ACE . . . */
1347       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1348         goto yourroom;
1349
1350 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1351       if (dirflag != 0)
1352         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1353           Newx(remove_name, NAM$C_MAXRSS+1, char);
1354           do_pathify_dirspec(name, remove_name, 0);
1355           rmsts = rmdir(remove_name);
1356           Safefree(remove_name);
1357         }
1358         else {
1359         rmsts = rmdir(remove_name);
1360         }
1361       else
1362 #endif
1363         rmsts = remove(remove_name);
1364       if (rmsts) {
1365         /* We blew it - dir with files in it, no write priv for
1366          * parent directory, etc.  Put things back the way they were. */
1367         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1368           goto yourroom;
1369         if (fndsts & 1) {
1370           addlst[0].bufadr = &oldace;
1371           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1372             goto yourroom;
1373         }
1374       }
1375     }
1376
1377     yourroom:
1378     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1379     /* We just deleted it, so of course it's not there.  Some versions of
1380      * VMS seem to return success on the unlock operation anyhow (after all
1381      * the unlock is successful), but others don't.
1382      */
1383     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1384     if (aclsts & 1) aclsts = fndsts;
1385     if (!(aclsts & 1)) {
1386       set_errno(EVMSERR);
1387       set_vaxc_errno(aclsts);
1388       Safefree(rspec);
1389       return -1;
1390     }
1391
1392     Safefree(rspec);
1393     return rmsts;
1394
1395 }  /* end of kill_file() */
1396 /*}}}*/
1397
1398
1399 /*{{{int do_rmdir(char *name)*/
1400 int
1401 Perl_do_rmdir(pTHX_ const char *name)
1402 {
1403     char dirfile[NAM$C_MAXRSS+1];
1404     int retval;
1405     Stat_t st;
1406
1407     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1408     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1409     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1410     return retval;
1411
1412 }  /* end of do_rmdir */
1413 /*}}}*/
1414
1415 /* kill_file
1416  * Delete any file to which user has control access, regardless of whether
1417  * delete access is explicitly allowed.
1418  * Limitations: User must have write access to parent directory.
1419  *              Does not block signals or ASTs; if interrupted in midstream
1420  *              may leave file with an altered ACL.
1421  * HANDLE WITH CARE!
1422  */
1423 /*{{{int kill_file(char *name)*/
1424 int
1425 Perl_kill_file(pTHX_ const char *name)
1426 {
1427     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1428     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1429     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1430     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1431     struct myacedef {
1432       unsigned char myace$b_length;
1433       unsigned char myace$b_type;
1434       unsigned short int myace$w_flags;
1435       unsigned long int myace$l_access;
1436       unsigned long int myace$l_ident;
1437     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1438                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1439       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1440      struct itmlst_3
1441        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1442                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1443        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1444        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1445        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1446        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1447
1448     /* Expand the input spec using RMS, since the CRTL remove() and
1449      * system services won't do this by themselves, so we may miss
1450      * a file "hiding" behind a logical name or search list. */
1451     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1452     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1453     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1454     /* If not, can changing protections help? */
1455     if (vaxc$errno != RMS$_PRV) return -1;
1456
1457     /* No, so we get our own UIC to use as a rights identifier,
1458      * and the insert an ACE at the head of the ACL which allows us
1459      * to delete the file.
1460      */
1461     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1462     fildsc.dsc$w_length = strlen(rspec);
1463     fildsc.dsc$a_pointer = rspec;
1464     cxt = 0;
1465     newace.myace$l_ident = oldace.myace$l_ident;
1466     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1467       switch (aclsts) {
1468         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1469           set_errno(ENOENT); break;
1470         case RMS$_DIR:
1471           set_errno(ENOTDIR); break;
1472         case RMS$_DEV:
1473           set_errno(ENODEV); break;
1474         case RMS$_SYN: case SS$_INVFILFOROP:
1475           set_errno(EINVAL); break;
1476         case RMS$_PRV:
1477           set_errno(EACCES); break;
1478         default:
1479           _ckvmssts(aclsts);
1480       }
1481       set_vaxc_errno(aclsts);
1482       return -1;
1483     }
1484     /* Grab any existing ACEs with this identifier in case we fail */
1485     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1486     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1487                     || fndsts == SS$_NOMOREACE ) {
1488       /* Add the new ACE . . . */
1489       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1490         goto yourroom;
1491       if ((rmsts = remove(name))) {
1492         /* We blew it - dir with files in it, no write priv for
1493          * parent directory, etc.  Put things back the way they were. */
1494         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1495           goto yourroom;
1496         if (fndsts & 1) {
1497           addlst[0].bufadr = &oldace;
1498           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1499             goto yourroom;
1500         }
1501       }
1502     }
1503
1504     yourroom:
1505     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1506     /* We just deleted it, so of course it's not there.  Some versions of
1507      * VMS seem to return success on the unlock operation anyhow (after all
1508      * the unlock is successful), but others don't.
1509      */
1510     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1511     if (aclsts & 1) aclsts = fndsts;
1512     if (!(aclsts & 1)) {
1513       set_errno(EVMSERR);
1514       set_vaxc_errno(aclsts);
1515       return -1;
1516     }
1517
1518     return rmsts;
1519
1520 }  /* end of kill_file() */
1521 /*}}}*/
1522
1523
1524 /*{{{int my_mkdir(char *,Mode_t)*/
1525 int
1526 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1527 {
1528   STRLEN dirlen = strlen(dir);
1529
1530   /* zero length string sometimes gives ACCVIO */
1531   if (dirlen == 0) return -1;
1532
1533   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1534    * null file name/type.  However, it's commonplace under Unix,
1535    * so we'll allow it for a gain in portability.
1536    */
1537   if (dir[dirlen-1] == '/') {
1538     char *newdir = savepvn(dir,dirlen-1);
1539     int ret = mkdir(newdir,mode);
1540     Safefree(newdir);
1541     return ret;
1542   }
1543   else return mkdir(dir,mode);
1544 }  /* end of my_mkdir */
1545 /*}}}*/
1546
1547 /*{{{int my_chdir(char *)*/
1548 int
1549 Perl_my_chdir(pTHX_ const char *dir)
1550 {
1551   STRLEN dirlen = strlen(dir);
1552
1553   /* zero length string sometimes gives ACCVIO */
1554   if (dirlen == 0) return -1;
1555   const char *dir1;
1556
1557   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1558    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1559    * so that existing scripts do not need to be changed.
1560    */
1561   dir1 = dir;
1562   while ((dirlen > 0) && (*dir1 == ' ')) {
1563     dir1++;
1564     dirlen--;
1565   }
1566
1567   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1568    * that implies
1569    * null file name/type.  However, it's commonplace under Unix,
1570    * so we'll allow it for a gain in portability.
1571    *
1572    * - Preview- '/' will be valid soon on VMS
1573    */
1574   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1575     char *newdir = savepvn(dir,dirlen-1);
1576     int ret = chdir(newdir);
1577     Safefree(newdir);
1578     return ret;
1579   }
1580   else return chdir(dir);
1581 }  /* end of my_chdir */
1582 /*}}}*/
1583
1584
1585 /*{{{FILE *my_tmpfile()*/
1586 FILE *
1587 my_tmpfile(void)
1588 {
1589   FILE *fp;
1590   char *cp;
1591
1592   if ((fp = tmpfile())) return fp;
1593
1594   Newx(cp,L_tmpnam+24,char);
1595   if (decc_filename_unix_only == 0)
1596     strcpy(cp,"Sys$Scratch:");
1597   else
1598     strcpy(cp,"/tmp/");
1599   tmpnam(cp+strlen(cp));
1600   strcat(cp,".Perltmp");
1601   fp = fopen(cp,"w+","fop=dlt");
1602   Safefree(cp);
1603   return fp;
1604 }
1605 /*}}}*/
1606
1607
1608 #ifndef HOMEGROWN_POSIX_SIGNALS
1609 /*
1610  * The C RTL's sigaction fails to check for invalid signal numbers so we
1611  * help it out a bit.  The docs are correct, but the actual routine doesn't
1612  * do what the docs say it will.
1613  */
1614 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1615 int
1616 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1617                    struct sigaction* oact)
1618 {
1619   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1620         SETERRNO(EINVAL, SS$_INVARG);
1621         return -1;
1622   }
1623   return sigaction(sig, act, oact);
1624 }
1625 /*}}}*/
1626 #endif
1627
1628 #ifdef KILL_BY_SIGPRC
1629 #include <errnodef.h>
1630
1631 /* We implement our own kill() using the undocumented system service
1632    sys$sigprc for one of two reasons:
1633
1634    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1635    target process to do a sys$exit, which usually can't be handled
1636    gracefully...certainly not by Perl and the %SIG{} mechanism.
1637
1638    2.) If the kill() in the CRTL can't be called from a signal
1639    handler without disappearing into the ether, i.e., the signal
1640    it purportedly sends is never trapped. Still true as of VMS 7.3.
1641
1642    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1643    in the target process rather than calling sys$exit.
1644
1645    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1646    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1647    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1648    with condition codes C$_SIG0+nsig*8, catching the exception on the
1649    target process and resignaling with appropriate arguments.
1650
1651    But we don't have that VMS 7.0+ exception handler, so if you
1652    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1653
1654    Also note that SIGTERM is listed in the docs as being "unimplemented",
1655    yet always seems to be signaled with a VMS condition code of 4 (and
1656    correctly handled for that code).  So we hardwire it in.
1657
1658    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1659    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1660    than signalling with an unrecognized (and unhandled by CRTL) code.
1661 */
1662
1663 #define _MY_SIG_MAX 17
1664
1665 static unsigned int
1666 Perl_sig_to_vmscondition_int(int sig)
1667 {
1668     static unsigned int sig_code[_MY_SIG_MAX+1] =
1669     {
1670         0,                  /*  0 ZERO     */
1671         SS$_HANGUP,         /*  1 SIGHUP   */
1672         SS$_CONTROLC,       /*  2 SIGINT   */
1673         SS$_CONTROLY,       /*  3 SIGQUIT  */
1674         SS$_RADRMOD,        /*  4 SIGILL   */
1675         SS$_BREAK,          /*  5 SIGTRAP  */
1676         SS$_OPCCUS,         /*  6 SIGABRT  */
1677         SS$_COMPAT,         /*  7 SIGEMT   */
1678 #ifdef __VAX
1679         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1680 #else
1681         SS$_HPARITH,        /*  8 SIGFPE AXP */
1682 #endif
1683         SS$_ABORT,          /*  9 SIGKILL  */
1684         SS$_ACCVIO,         /* 10 SIGBUS   */
1685         SS$_ACCVIO,         /* 11 SIGSEGV  */
1686         SS$_BADPARAM,       /* 12 SIGSYS   */
1687         SS$_NOMBX,          /* 13 SIGPIPE  */
1688         SS$_ASTFLT,         /* 14 SIGALRM  */
1689         4,                  /* 15 SIGTERM  */
1690         0,                  /* 16 SIGUSR1  */
1691         0                   /* 17 SIGUSR2  */
1692     };
1693
1694 #if __VMS_VER >= 60200000
1695     static int initted = 0;
1696     if (!initted) {
1697         initted = 1;
1698         sig_code[16] = C$_SIGUSR1;
1699         sig_code[17] = C$_SIGUSR2;
1700     }
1701 #endif
1702
1703     if (sig < _SIG_MIN) return 0;
1704     if (sig > _MY_SIG_MAX) return 0;
1705     return sig_code[sig];
1706 }
1707
1708 unsigned int
1709 Perl_sig_to_vmscondition(int sig)
1710 {
1711 #ifdef SS$_DEBUG
1712     if (vms_debug_on_exception != 0)
1713         lib$signal(SS$_DEBUG);
1714 #endif
1715     return Perl_sig_to_vmscondition_int(sig);
1716 }
1717
1718
1719 int
1720 Perl_my_kill(int pid, int sig)
1721 {
1722     dTHX;
1723     int iss;
1724     unsigned int code;
1725     int sys$sigprc(unsigned int *pidadr,
1726                      struct dsc$descriptor_s *prcname,
1727                      unsigned int code);
1728
1729      /* sig 0 means validate the PID */
1730     /*------------------------------*/
1731     if (sig == 0) {
1732         const unsigned long int jpicode = JPI$_PID;
1733         pid_t ret_pid;
1734         int status;
1735         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1736         if ($VMS_STATUS_SUCCESS(status))
1737            return 0;
1738         switch (status) {
1739         case SS$_NOSUCHNODE:
1740         case SS$_UNREACHABLE:
1741         case SS$_NONEXPR:
1742            errno = ESRCH;
1743            break;
1744         case SS$_NOPRIV:
1745            errno = EPERM;
1746            break;
1747         default:
1748            errno = EVMSERR;
1749         }
1750         vaxc$errno=status;
1751         return -1;
1752     }
1753
1754     code = Perl_sig_to_vmscondition_int(sig);
1755
1756     if (!code) {
1757         SETERRNO(EINVAL, SS$_BADPARAM);
1758         return -1;
1759     }
1760
1761     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1762      * signals are to be sent to multiple processes.
1763      *  pid = 0 - all processes in group except ones that the system exempts
1764      *  pid = -1 - all processes except ones that the system exempts
1765      *  pid = -n - all processes in group (abs(n)) except ...
1766      * For now, just report as not supported.
1767      */
1768
1769     if (pid <= 0) {
1770         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1771         return -1;
1772     }
1773
1774     iss = sys$sigprc((unsigned int *)&pid,0,code);
1775     if (iss&1) return 0;
1776
1777     switch (iss) {
1778       case SS$_NOPRIV:
1779         set_errno(EPERM);  break;
1780       case SS$_NONEXPR:
1781       case SS$_NOSUCHNODE:
1782       case SS$_UNREACHABLE:
1783         set_errno(ESRCH);  break;
1784       case SS$_INSFMEM:
1785         set_errno(ENOMEM); break;
1786       default:
1787         _ckvmssts(iss);
1788         set_errno(EVMSERR);
1789     }
1790     set_vaxc_errno(iss);
1791
1792     return -1;
1793 }
1794 #endif
1795
1796 /* Routine to convert a VMS status code to a UNIX status code.
1797 ** More tricky than it appears because of conflicting conventions with
1798 ** existing code.
1799 **
1800 ** VMS status codes are a bit mask, with the least significant bit set for
1801 ** success.
1802 **
1803 ** Special UNIX status of EVMSERR indicates that no translation is currently
1804 ** available, and programs should check the VMS status code.
1805 **
1806 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1807 ** decoding.
1808 */
1809
1810 #ifndef C_FACILITY_NO
1811 #define C_FACILITY_NO 0x350000
1812 #endif
1813 #ifndef DCL_IVVERB
1814 #define DCL_IVVERB 0x38090
1815 #endif
1816
1817 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1818 {
1819 int facility;
1820 int fac_sp;
1821 int msg_no;
1822 int msg_status;
1823 int unix_status;
1824
1825   /* Assume the best or the worst */
1826   if (vms_status & STS$M_SUCCESS)
1827     unix_status = 0;
1828   else
1829     unix_status = EVMSERR;
1830
1831   msg_status = vms_status & ~STS$M_CONTROL;
1832
1833   facility = vms_status & STS$M_FAC_NO;
1834   fac_sp = vms_status & STS$M_FAC_SP;
1835   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1836
1837   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1838     switch(msg_no) {
1839     case SS$_NORMAL:
1840         unix_status = 0;
1841         break;
1842     case SS$_ACCVIO:
1843         unix_status = EFAULT;
1844         break;
1845     case SS$_DEVOFFLINE:
1846         unix_status = EBUSY;
1847         break;
1848     case SS$_CLEARED:
1849         unix_status = ENOTCONN;
1850         break;
1851     case SS$_IVCHAN:
1852     case SS$_IVLOGNAM:
1853     case SS$_BADPARAM:
1854     case SS$_IVLOGTAB:
1855     case SS$_NOLOGNAM:
1856     case SS$_NOLOGTAB:
1857     case SS$_INVFILFOROP:
1858     case SS$_INVARG:
1859     case SS$_NOSUCHID:
1860     case SS$_IVIDENT:
1861         unix_status = EINVAL;
1862         break;
1863     case SS$_UNSUPPORTED:
1864         unix_status = ENOTSUP;
1865         break;
1866     case SS$_FILACCERR:
1867     case SS$_NOGRPPRV:
1868     case SS$_NOSYSPRV:
1869         unix_status = EACCES;
1870         break;
1871     case SS$_DEVICEFULL:
1872         unix_status = ENOSPC;
1873         break;
1874     case SS$_NOSUCHDEV:
1875         unix_status = ENODEV;
1876         break;
1877     case SS$_NOSUCHFILE:
1878     case SS$_NOSUCHOBJECT:
1879         unix_status = ENOENT;
1880         break;
1881     case SS$_ABORT:                                 /* Fatal case */
1882     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1883     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1884         unix_status = EINTR;
1885         break;
1886     case SS$_BUFFEROVF:
1887         unix_status = E2BIG;
1888         break;
1889     case SS$_INSFMEM:
1890         unix_status = ENOMEM;
1891         break;
1892     case SS$_NOPRIV:
1893         unix_status = EPERM;
1894         break;
1895     case SS$_NOSUCHNODE:
1896     case SS$_UNREACHABLE:
1897         unix_status = ESRCH;
1898         break;
1899     case SS$_NONEXPR:
1900         unix_status = ECHILD;
1901         break;
1902     default:
1903         if ((facility == 0) && (msg_no < 8)) {
1904           /* These are not real VMS status codes so assume that they are
1905           ** already UNIX status codes
1906           */
1907           unix_status = msg_no;
1908           break;
1909         }
1910     }
1911   }
1912   else {
1913     /* Translate a POSIX exit code to a UNIX exit code */
1914     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1915         unix_status = (msg_no & 0x07F8) >> 3;
1916     }
1917     else {
1918
1919          /* Documented traditional behavior for handling VMS child exits */
1920         /*--------------------------------------------------------------*/
1921         if (child_flag != 0) {
1922
1923              /* Success / Informational return 0 */
1924             /*----------------------------------*/
1925             if (msg_no & STS$K_SUCCESS)
1926                 return 0;
1927
1928              /* Warning returns 1 */
1929             /*-------------------*/
1930             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1931                 return 1;
1932
1933              /* Everything else pass through the severity bits */
1934             /*------------------------------------------------*/
1935             return (msg_no & STS$M_SEVERITY);
1936         }
1937
1938          /* Normal VMS status to ERRNO mapping attempt */
1939         /*--------------------------------------------*/
1940         switch(msg_status) {
1941         /* case RMS$_EOF: */ /* End of File */
1942         case RMS$_FNF:  /* File Not Found */
1943         case RMS$_DNF:  /* Dir Not Found */
1944                 unix_status = ENOENT;
1945                 break;
1946         case RMS$_RNF:  /* Record Not Found */
1947                 unix_status = ESRCH;
1948                 break;
1949         case RMS$_DIR:
1950                 unix_status = ENOTDIR;
1951                 break;
1952         case RMS$_DEV:
1953                 unix_status = ENODEV;
1954                 break;
1955         case RMS$_IFI:
1956         case RMS$_FAC:
1957         case RMS$_ISI:
1958                 unix_status = EBADF;
1959                 break;
1960         case RMS$_FEX:
1961                 unix_status = EEXIST;
1962                 break;
1963         case RMS$_SYN:
1964         case RMS$_FNM:
1965         case LIB$_INVSTRDES:
1966         case LIB$_INVARG:
1967         case LIB$_NOSUCHSYM:
1968         case LIB$_INVSYMNAM:
1969         case DCL_IVVERB:
1970                 unix_status = EINVAL;
1971                 break;
1972         case CLI$_BUFOVF:
1973         case RMS$_RTB:
1974         case CLI$_TKNOVF:
1975         case CLI$_RSLOVF:
1976                 unix_status = E2BIG;
1977                 break;
1978         case RMS$_PRV:  /* No privilege */
1979         case RMS$_ACC:  /* ACP file access failed */
1980         case RMS$_WLK:  /* Device write locked */
1981                 unix_status = EACCES;
1982                 break;
1983         /* case RMS$_NMF: */  /* No more files */
1984         }
1985     }
1986   }
1987
1988   return unix_status;
1989 }
1990
1991 /* Try to guess at what VMS error status should go with a UNIX errno
1992  * value.  This is hard to do as there could be many possible VMS
1993  * error statuses that caused the errno value to be set.
1994  */
1995
1996 int Perl_unix_status_to_vms(int unix_status)
1997 {
1998 int test_unix_status;
1999
2000      /* Trivial cases first */
2001     /*---------------------*/
2002     if (unix_status == EVMSERR)
2003         return vaxc$errno;
2004
2005      /* Is vaxc$errno sane? */
2006     /*---------------------*/
2007     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2008     if (test_unix_status == unix_status)
2009         return vaxc$errno;
2010
2011      /* If way out of range, must be VMS code already */
2012     /*-----------------------------------------------*/
2013     if (unix_status > EVMSERR)
2014         return unix_status;
2015
2016      /* If out of range, punt */
2017     /*-----------------------*/
2018     if (unix_status > __ERRNO_MAX)
2019         return SS$_ABORT;
2020
2021
2022      /* Ok, now we have to do it the hard way. */
2023     /*----------------------------------------*/
2024     switch(unix_status) {
2025     case 0:     return SS$_NORMAL;
2026     case EPERM: return SS$_NOPRIV;
2027     case ENOENT: return SS$_NOSUCHOBJECT;
2028     case ESRCH: return SS$_UNREACHABLE;
2029     case EINTR: return SS$_ABORT;
2030     /* case EIO: */
2031     /* case ENXIO:  */
2032     case E2BIG: return SS$_BUFFEROVF;
2033     /* case ENOEXEC */
2034     case EBADF: return RMS$_IFI;
2035     case ECHILD: return SS$_NONEXPR;
2036     /* case EAGAIN */
2037     case ENOMEM: return SS$_INSFMEM;
2038     case EACCES: return SS$_FILACCERR;
2039     case EFAULT: return SS$_ACCVIO;
2040     /* case ENOTBLK */
2041     case EBUSY: return SS$_DEVOFFLINE;
2042     case EEXIST: return RMS$_FEX;
2043     /* case EXDEV */
2044     case ENODEV: return SS$_NOSUCHDEV;
2045     case ENOTDIR: return RMS$_DIR;
2046     /* case EISDIR */
2047     case EINVAL: return SS$_INVARG;
2048     /* case ENFILE */
2049     /* case EMFILE */
2050     /* case ENOTTY */
2051     /* case ETXTBSY */
2052     /* case EFBIG */
2053     case ENOSPC: return SS$_DEVICEFULL;
2054     case ESPIPE: return LIB$_INVARG;
2055     /* case EROFS: */
2056     /* case EMLINK: */
2057     /* case EPIPE: */
2058     /* case EDOM */
2059     case ERANGE: return LIB$_INVARG;
2060     /* case EWOULDBLOCK */
2061     /* case EINPROGRESS */
2062     /* case EALREADY */
2063     /* case ENOTSOCK */
2064     /* case EDESTADDRREQ */
2065     /* case EMSGSIZE */
2066     /* case EPROTOTYPE */
2067     /* case ENOPROTOOPT */
2068     /* case EPROTONOSUPPORT */
2069     /* case ESOCKTNOSUPPORT */
2070     /* case EOPNOTSUPP */
2071     /* case EPFNOSUPPORT */
2072     /* case EAFNOSUPPORT */
2073     /* case EADDRINUSE */
2074     /* case EADDRNOTAVAIL */
2075     /* case ENETDOWN */
2076     /* case ENETUNREACH */
2077     /* case ENETRESET */
2078     /* case ECONNABORTED */
2079     /* case ECONNRESET */
2080     /* case ENOBUFS */
2081     /* case EISCONN */
2082     case ENOTCONN: return SS$_CLEARED;
2083     /* case ESHUTDOWN */
2084     /* case ETOOMANYREFS */
2085     /* case ETIMEDOUT */
2086     /* case ECONNREFUSED */
2087     /* case ELOOP */
2088     /* case ENAMETOOLONG */
2089     /* case EHOSTDOWN */
2090     /* case EHOSTUNREACH */
2091     /* case ENOTEMPTY */
2092     /* case EPROCLIM */
2093     /* case EUSERS  */
2094     /* case EDQUOT  */
2095     /* case ENOMSG  */
2096     /* case EIDRM */
2097     /* case EALIGN */
2098     /* case ESTALE */
2099     /* case EREMOTE */
2100     /* case ENOLCK */
2101     /* case ENOSYS */
2102     /* case EFTYPE */
2103     /* case ECANCELED */
2104     /* case EFAIL */
2105     /* case EINPROG */
2106     case ENOTSUP:
2107         return SS$_UNSUPPORTED;
2108     /* case EDEADLK */
2109     /* case ENWAIT */
2110     /* case EILSEQ */
2111     /* case EBADCAT */
2112     /* case EBADMSG */
2113     /* case EABANDONED */
2114     default:
2115         return SS$_ABORT; /* punt */
2116     }
2117
2118   return SS$_ABORT; /* Should not get here */
2119 }
2120
2121
2122 /* default piping mailbox size */
2123 #define PERL_BUFSIZ        512
2124
2125
2126 static void
2127 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2128 {
2129   unsigned long int mbxbufsiz;
2130   static unsigned long int syssize = 0;
2131   unsigned long int dviitm = DVI$_DEVNAM;
2132   char csize[LNM$C_NAMLENGTH+1];
2133   int sts;
2134
2135   if (!syssize) {
2136     unsigned long syiitm = SYI$_MAXBUF;
2137     /*
2138      * Get the SYSGEN parameter MAXBUF
2139      *
2140      * If the logical 'PERL_MBX_SIZE' is defined
2141      * use the value of the logical instead of PERL_BUFSIZ, but
2142      * keep the size between 128 and MAXBUF.
2143      *
2144      */
2145     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2146   }
2147
2148   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2149       mbxbufsiz = atoi(csize);
2150   } else {
2151       mbxbufsiz = PERL_BUFSIZ;
2152   }
2153   if (mbxbufsiz < 128) mbxbufsiz = 128;
2154   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2155
2156   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2157
2158   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2159   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2160
2161 }  /* end of create_mbx() */
2162
2163
2164 /*{{{  my_popen and my_pclose*/
2165
2166 typedef struct _iosb           IOSB;
2167 typedef struct _iosb*         pIOSB;
2168 typedef struct _pipe           Pipe;
2169 typedef struct _pipe*         pPipe;
2170 typedef struct pipe_details    Info;
2171 typedef struct pipe_details*  pInfo;
2172 typedef struct _srqp            RQE;
2173 typedef struct _srqp*          pRQE;
2174 typedef struct _tochildbuf      CBuf;
2175 typedef struct _tochildbuf*    pCBuf;
2176
2177 struct _iosb {
2178     unsigned short status;
2179     unsigned short count;
2180     unsigned long  dvispec;
2181 };
2182
2183 #pragma member_alignment save
2184 #pragma nomember_alignment quadword
2185 struct _srqp {          /* VMS self-relative queue entry */
2186     unsigned long qptr[2];
2187 };
2188 #pragma member_alignment restore
2189 static RQE  RQE_ZERO = {0,0};
2190
2191 struct _tochildbuf {
2192     RQE             q;
2193     int             eof;
2194     unsigned short  size;
2195     char            *buf;
2196 };
2197
2198 struct _pipe {
2199     RQE            free;
2200     RQE            wait;
2201     int            fd_out;
2202     unsigned short chan_in;
2203     unsigned short chan_out;
2204     char          *buf;
2205     unsigned int   bufsize;
2206     IOSB           iosb;
2207     IOSB           iosb2;
2208     int           *pipe_done;
2209     int            retry;
2210     int            type;
2211     int            shut_on_empty;
2212     int            need_wake;
2213     pPipe         *home;
2214     pInfo          info;
2215     pCBuf          curr;
2216     pCBuf          curr2;
2217 #if defined(PERL_IMPLICIT_CONTEXT)
2218     void            *thx;           /* Either a thread or an interpreter */
2219                                     /* pointer, depending on how we're built */
2220 #endif
2221 };
2222
2223
2224 struct pipe_details
2225 {
2226     pInfo           next;
2227     PerlIO *fp;  /* file pointer to pipe mailbox */
2228     int useFILE; /* using stdio, not perlio */
2229     int pid;   /* PID of subprocess */
2230     int mode;  /* == 'r' if pipe open for reading */
2231     int done;  /* subprocess has completed */
2232     int waiting; /* waiting for completion/closure */
2233     int             closing;        /* my_pclose is closing this pipe */
2234     unsigned long   completion;     /* termination status of subprocess */
2235     pPipe           in;             /* pipe in to sub */
2236     pPipe           out;            /* pipe out of sub */
2237     pPipe           err;            /* pipe of sub's sys$error */
2238     int             in_done;        /* true when in pipe finished */
2239     int             out_done;
2240     int             err_done;
2241 };
2242
2243 struct exit_control_block
2244 {
2245     struct exit_control_block *flink;
2246     unsigned long int   (*exit_routine)();
2247     unsigned long int arg_count;
2248     unsigned long int *status_address;
2249     unsigned long int exit_status;
2250 };
2251
2252 typedef struct _closed_pipes    Xpipe;
2253 typedef struct _closed_pipes*  pXpipe;
2254
2255 struct _closed_pipes {
2256     int             pid;            /* PID of subprocess */
2257     unsigned long   completion;     /* termination status of subprocess */
2258 };
2259 #define NKEEPCLOSED 50
2260 static Xpipe closed_list[NKEEPCLOSED];
2261 static int   closed_index = 0;
2262 static int   closed_num = 0;
2263
2264 #define RETRY_DELAY     "0 ::0.20"
2265 #define MAX_RETRY              50
2266
2267 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2268 static unsigned long mypid;
2269 static unsigned long delaytime[2];
2270
2271 static pInfo open_pipes = NULL;
2272 static $DESCRIPTOR(nl_desc, "NL:");
2273
2274 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2275
2276
2277
2278 static unsigned long int
2279 pipe_exit_routine(pTHX)
2280 {
2281     pInfo info;
2282     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2283     int sts, did_stuff, need_eof, j;
2284
2285     /*
2286         flush any pending i/o
2287     */
2288     info = open_pipes;
2289     while (info) {
2290         if (info->fp) {
2291            if (!info->useFILE)
2292                PerlIO_flush(info->fp);   /* first, flush data */
2293            else
2294                fflush((FILE *)info->fp);
2295         }
2296         info = info->next;
2297     }
2298
2299     /*
2300      next we try sending an EOF...ignore if doesn't work, make sure we
2301      don't hang
2302     */
2303     did_stuff = 0;
2304     info = open_pipes;
2305
2306     while (info) {
2307       int need_eof;
2308       _ckvmssts_noperl(sys$setast(0));
2309       if (info->in && !info->in->shut_on_empty) {
2310         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2311                           0, 0, 0, 0, 0, 0));
2312         info->waiting = 1;
2313         did_stuff = 1;
2314       }
2315       _ckvmssts_noperl(sys$setast(1));
2316       info = info->next;
2317     }
2318
2319     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2320
2321     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2322         int nwait = 0;
2323
2324         info = open_pipes;
2325         while (info) {
2326           _ckvmssts_noperl(sys$setast(0));
2327           if (info->waiting && info->done)
2328                 info->waiting = 0;
2329           nwait += info->waiting;
2330           _ckvmssts_noperl(sys$setast(1));
2331           info = info->next;
2332         }
2333         if (!nwait) break;
2334         sleep(1);
2335     }
2336
2337     did_stuff = 0;
2338     info = open_pipes;
2339     while (info) {
2340       _ckvmssts_noperl(sys$setast(0));
2341       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2342         sts = sys$forcex(&info->pid,0,&abort);
2343         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2344         did_stuff = 1;
2345       }
2346       _ckvmssts_noperl(sys$setast(1));
2347       info = info->next;
2348     }
2349
2350     /* again, wait for effect */
2351
2352     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2353         int nwait = 0;
2354
2355         info = open_pipes;
2356         while (info) {
2357           _ckvmssts_noperl(sys$setast(0));
2358           if (info->waiting && info->done)
2359                 info->waiting = 0;
2360           nwait += info->waiting;
2361           _ckvmssts_noperl(sys$setast(1));
2362           info = info->next;
2363         }
2364         if (!nwait) break;
2365         sleep(1);
2366     }
2367
2368     info = open_pipes;
2369     while (info) {
2370       _ckvmssts_noperl(sys$setast(0));
2371       if (!info->done) {  /* We tried to be nice . . . */
2372         sts = sys$delprc(&info->pid,0);
2373         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2374       }
2375       _ckvmssts_noperl(sys$setast(1));
2376       info = info->next;
2377     }
2378
2379     while(open_pipes) {
2380       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2381       else if (!(sts & 1)) retsts = sts;
2382     }
2383     return retsts;
2384 }
2385
2386 static struct exit_control_block pipe_exitblock =
2387        {(struct exit_control_block *) 0,
2388         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2389
2390 static void pipe_mbxtofd_ast(pPipe p);
2391 static void pipe_tochild1_ast(pPipe p);
2392 static void pipe_tochild2_ast(pPipe p);
2393
2394 static void
2395 popen_completion_ast(pInfo info)
2396 {
2397   pInfo i = open_pipes;
2398   int iss;
2399   int sts;
2400   pXpipe x;
2401
2402   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2403   closed_list[closed_index].pid = info->pid;
2404   closed_list[closed_index].completion = info->completion;
2405   closed_index++;
2406   if (closed_index == NKEEPCLOSED)
2407     closed_index = 0;
2408   closed_num++;
2409
2410   while (i) {
2411     if (i == info) break;
2412     i = i->next;
2413   }
2414   if (!i) return;       /* unlinked, probably freed too */
2415
2416   info->done = TRUE;
2417
2418 /*
2419     Writing to subprocess ...
2420             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2421
2422             chan_out may be waiting for "done" flag, or hung waiting
2423             for i/o completion to child...cancel the i/o.  This will
2424             put it into "snarf mode" (done but no EOF yet) that discards
2425             input.
2426
2427     Output from subprocess (stdout, stderr) needs to be flushed and
2428     shut down.   We try sending an EOF, but if the mbx is full the pipe
2429     routine should still catch the "shut_on_empty" flag, telling it to
2430     use immediate-style reads so that "mbx empty" -> EOF.
2431
2432
2433 */
2434   if (info->in && !info->in_done) {               /* only for mode=w */
2435         if (info->in->shut_on_empty && info->in->need_wake) {
2436             info->in->need_wake = FALSE;
2437             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2438         } else {
2439             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2440         }
2441   }
2442
2443   if (info->out && !info->out_done) {             /* were we also piping output? */
2444       info->out->shut_on_empty = TRUE;
2445       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2446       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2447       _ckvmssts_noperl(iss);
2448   }
2449
2450   if (info->err && !info->err_done) {        /* we were piping stderr */
2451         info->err->shut_on_empty = TRUE;
2452         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2453         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2454         _ckvmssts_noperl(iss);
2455   }
2456   _ckvmssts_noperl(sys$setef(pipe_ef));
2457
2458 }
2459
2460 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2461 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2462
2463 /*
2464     we actually differ from vmstrnenv since we use this to
2465     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2466     are pointing to the same thing
2467 */
2468
2469 static unsigned short
2470 popen_translate(pTHX_ char *logical, char *result)
2471 {
2472     int iss;
2473     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2474     $DESCRIPTOR(d_log,"");
2475     struct _il3 {
2476         unsigned short length;
2477         unsigned short code;
2478         char *         buffer_addr;
2479         unsigned short *retlenaddr;
2480     } itmlst[2];
2481     unsigned short l, ifi;
2482
2483     d_log.dsc$a_pointer = logical;
2484     d_log.dsc$w_length  = strlen(logical);
2485
2486     itmlst[0].code = LNM$_STRING;
2487     itmlst[0].length = 255;
2488     itmlst[0].buffer_addr = result;
2489     itmlst[0].retlenaddr = &l;
2490
2491     itmlst[1].code = 0;
2492     itmlst[1].length = 0;
2493     itmlst[1].buffer_addr = 0;
2494     itmlst[1].retlenaddr = 0;
2495
2496     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2497     if (iss == SS$_NOLOGNAM) {
2498         iss = SS$_NORMAL;
2499         l = 0;
2500     }
2501     if (!(iss&1)) lib$signal(iss);
2502     result[l] = '\0';
2503 /*
2504     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2505     strip it off and return the ifi, if any
2506 */
2507     ifi  = 0;
2508     if (result[0] == 0x1b && result[1] == 0x00) {
2509         memmove(&ifi,result+2,2);
2510         strcpy(result,result+4);
2511     }
2512     return ifi;     /* this is the RMS internal file id */
2513 }
2514
2515 static void pipe_infromchild_ast(pPipe p);
2516
2517 /*
2518     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2519     inside an AST routine without worrying about reentrancy and which Perl
2520     memory allocator is being used.
2521
2522     We read data and queue up the buffers, then spit them out one at a
2523     time to the output mailbox when the output mailbox is ready for one.
2524
2525 */
2526 #define INITIAL_TOCHILDQUEUE  2
2527
2528 static pPipe
2529 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2530 {
2531     pPipe p;
2532     pCBuf b;
2533     char mbx1[64], mbx2[64];
2534     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2535                                       DSC$K_CLASS_S, mbx1},
2536                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2537                                       DSC$K_CLASS_S, mbx2};
2538     unsigned int dviitm = DVI$_DEVBUFSIZ;
2539     int j, n;
2540
2541     n = sizeof(Pipe);
2542     _ckvmssts(lib$get_vm(&n, &p));
2543
2544     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2545     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2546     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2547
2548     p->buf           = 0;
2549     p->shut_on_empty = FALSE;
2550     p->need_wake     = FALSE;
2551     p->type          = 0;
2552     p->retry         = 0;
2553     p->iosb.status   = SS$_NORMAL;
2554     p->iosb2.status  = SS$_NORMAL;
2555     p->free          = RQE_ZERO;
2556     p->wait          = RQE_ZERO;
2557     p->curr          = 0;
2558     p->curr2         = 0;
2559     p->info          = 0;
2560 #ifdef PERL_IMPLICIT_CONTEXT
2561     p->thx           = aTHX;
2562 #endif
2563
2564     n = sizeof(CBuf) + p->bufsize;
2565
2566     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2567         _ckvmssts(lib$get_vm(&n, &b));
2568         b->buf = (char *) b + sizeof(CBuf);
2569         _ckvmssts(lib$insqhi(b, &p->free));
2570     }
2571
2572     pipe_tochild2_ast(p);
2573     pipe_tochild1_ast(p);
2574     strcpy(wmbx, mbx1);
2575     strcpy(rmbx, mbx2);
2576     return p;
2577 }
2578
2579 /*  reads the MBX Perl is writing, and queues */
2580
2581 static void
2582 pipe_tochild1_ast(pPipe p)
2583 {
2584     pCBuf b = p->curr;
2585     int iss = p->iosb.status;
2586     int eof = (iss == SS$_ENDOFFILE);
2587     int sts;
2588 #ifdef PERL_IMPLICIT_CONTEXT
2589     pTHX = p->thx;
2590 #endif
2591
2592     if (p->retry) {
2593         if (eof) {
2594             p->shut_on_empty = TRUE;
2595             b->eof     = TRUE;
2596             _ckvmssts(sys$dassgn(p->chan_in));
2597         } else  {
2598             _ckvmssts(iss);
2599         }
2600
2601         b->eof  = eof;
2602         b->size = p->iosb.count;
2603         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2604         if (p->need_wake) {
2605             p->need_wake = FALSE;
2606             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2607         }
2608     } else {
2609         p->retry = 1;   /* initial call */
2610     }
2611
2612     if (eof) {                  /* flush the free queue, return when done */
2613         int n = sizeof(CBuf) + p->bufsize;
2614         while (1) {
2615             iss = lib$remqti(&p->free, &b);
2616             if (iss == LIB$_QUEWASEMP) return;
2617             _ckvmssts(iss);
2618             _ckvmssts(lib$free_vm(&n, &b));
2619         }
2620     }
2621
2622     iss = lib$remqti(&p->free, &b);
2623     if (iss == LIB$_QUEWASEMP) {
2624         int n = sizeof(CBuf) + p->bufsize;
2625         _ckvmssts(lib$get_vm(&n, &b));
2626         b->buf = (char *) b + sizeof(CBuf);
2627     } else {
2628        _ckvmssts(iss);
2629     }
2630
2631     p->curr = b;
2632     iss = sys$qio(0,p->chan_in,
2633              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2634              &p->iosb,
2635              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2636     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2637     _ckvmssts(iss);
2638 }
2639
2640
2641 /* writes queued buffers to output, waits for each to complete before
2642    doing the next */
2643
2644 static void
2645 pipe_tochild2_ast(pPipe p)
2646 {
2647     pCBuf b = p->curr2;
2648     int iss = p->iosb2.status;
2649     int n = sizeof(CBuf) + p->bufsize;
2650     int done = (p->info && p->info->done) ||
2651               iss == SS$_CANCEL || iss == SS$_ABORT;
2652 #if defined(PERL_IMPLICIT_CONTEXT)
2653     pTHX = p->thx;
2654 #endif
2655
2656     do {
2657         if (p->type) {         /* type=1 has old buffer, dispose */
2658             if (p->shut_on_empty) {
2659                 _ckvmssts(lib$free_vm(&n, &b));
2660             } else {
2661                 _ckvmssts(lib$insqhi(b, &p->free));
2662             }
2663             p->type = 0;
2664         }
2665
2666         iss = lib$remqti(&p->wait, &b);
2667         if (iss == LIB$_QUEWASEMP) {
2668             if (p->shut_on_empty) {
2669                 if (done) {
2670                     _ckvmssts(sys$dassgn(p->chan_out));
2671                     *p->pipe_done = TRUE;
2672                     _ckvmssts(sys$setef(pipe_ef));
2673                 } else {
2674                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2675                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2676                 }
2677                 return;
2678             }
2679             p->need_wake = TRUE;
2680             return;
2681         }
2682         _ckvmssts(iss);
2683         p->type = 1;
2684     } while (done);
2685
2686
2687     p->curr2 = b;
2688     if (b->eof) {
2689         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2690             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2691     } else {
2692         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2693             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2694     }
2695
2696     return;
2697
2698 }
2699
2700
2701 static pPipe
2702 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2703 {
2704     pPipe p;
2705     char mbx1[64], mbx2[64];
2706     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2707                                       DSC$K_CLASS_S, mbx1},
2708                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2709                                       DSC$K_CLASS_S, mbx2};
2710     unsigned int dviitm = DVI$_DEVBUFSIZ;
2711
2712     int n = sizeof(Pipe);
2713     _ckvmssts(lib$get_vm(&n, &p));
2714     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2715     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2716
2717     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2718     n = p->bufsize * sizeof(char);
2719     _ckvmssts(lib$get_vm(&n, &p->buf));
2720     p->shut_on_empty = FALSE;
2721     p->info   = 0;
2722     p->type   = 0;
2723     p->iosb.status = SS$_NORMAL;
2724 #if defined(PERL_IMPLICIT_CONTEXT)
2725     p->thx = aTHX;
2726 #endif
2727     pipe_infromchild_ast(p);
2728
2729     strcpy(wmbx, mbx1);
2730     strcpy(rmbx, mbx2);
2731     return p;
2732 }
2733
2734 static void
2735 pipe_infromchild_ast(pPipe p)
2736 {
2737     int iss = p->iosb.status;
2738     int eof = (iss == SS$_ENDOFFILE);
2739     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2740     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2741 #if defined(PERL_IMPLICIT_CONTEXT)
2742     pTHX = p->thx;
2743 #endif
2744
2745     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2746         _ckvmssts(sys$dassgn(p->chan_out));
2747         p->chan_out = 0;
2748     }
2749
2750     /* read completed:
2751             input shutdown if EOF from self (done or shut_on_empty)
2752             output shutdown if closing flag set (my_pclose)
2753             send data/eof from child or eof from self
2754             otherwise, re-read (snarf of data from child)
2755     */
2756
2757     if (p->type == 1) {
2758         p->type = 0;
2759         if (myeof && p->chan_in) {                  /* input shutdown */
2760             _ckvmssts(sys$dassgn(p->chan_in));
2761             p->chan_in = 0;
2762         }
2763
2764         if (p->chan_out) {
2765             if (myeof || kideof) {      /* pass EOF to parent */
2766                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2767                               pipe_infromchild_ast, p,
2768                               0, 0, 0, 0, 0, 0));
2769                 return;
2770             } else if (eof) {       /* eat EOF --- fall through to read*/
2771
2772             } else {                /* transmit data */
2773                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2774                               pipe_infromchild_ast,p,
2775                               p->buf, p->iosb.count, 0, 0, 0, 0));
2776                 return;
2777             }
2778         }
2779     }
2780
2781     /*  everything shut? flag as done */
2782
2783     if (!p->chan_in && !p->chan_out) {
2784         *p->pipe_done = TRUE;
2785         _ckvmssts(sys$setef(pipe_ef));
2786         return;
2787     }
2788
2789     /* write completed (or read, if snarfing from child)
2790             if still have input active,
2791                queue read...immediate mode if shut_on_empty so we get EOF if empty
2792             otherwise,
2793                check if Perl reading, generate EOFs as needed
2794     */
2795
2796     if (p->type == 0) {
2797         p->type = 1;
2798         if (p->chan_in) {
2799             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2800                           pipe_infromchild_ast,p,
2801                           p->buf, p->bufsize, 0, 0, 0, 0);
2802             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2803             _ckvmssts(iss);
2804         } else {           /* send EOFs for extra reads */
2805             p->iosb.status = SS$_ENDOFFILE;
2806             p->iosb.dvispec = 0;
2807             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2808                       0, 0, 0,
2809                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2810         }
2811     }
2812 }
2813
2814 static pPipe
2815 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2816 {
2817     pPipe p;
2818     char mbx[64];
2819     unsigned long dviitm = DVI$_DEVBUFSIZ;
2820     struct stat s;
2821     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2822                                       DSC$K_CLASS_S, mbx};
2823     int n = sizeof(Pipe);
2824
2825     /* things like terminals and mbx's don't need this filter */
2826     if (fd && fstat(fd,&s) == 0) {
2827         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2828         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2829                                          DSC$K_CLASS_S, s.st_dev};
2830
2831         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2832         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2833             strcpy(out, s.st_dev);
2834             return 0;
2835         }
2836     }
2837
2838     _ckvmssts(lib$get_vm(&n, &p));
2839     p->fd_out = dup(fd);
2840     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2841     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2842     n = (p->bufsize+1) * sizeof(char);
2843     _ckvmssts(lib$get_vm(&n, &p->buf));
2844     p->shut_on_empty = FALSE;
2845     p->retry = 0;
2846     p->info  = 0;
2847     strcpy(out, mbx);
2848
2849     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2850                   pipe_mbxtofd_ast, p,
2851                   p->buf, p->bufsize, 0, 0, 0, 0));
2852
2853     return p;
2854 }
2855
2856 static void
2857 pipe_mbxtofd_ast(pPipe p)
2858 {
2859     int iss = p->iosb.status;
2860     int done = p->info->done;
2861     int iss2;
2862     int eof = (iss == SS$_ENDOFFILE);
2863     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2864     int err = !(iss&1) && !eof;
2865 #if defined(PERL_IMPLICIT_CONTEXT)
2866     pTHX = p->thx;
2867 #endif
2868
2869     if (done && myeof) {               /* end piping */
2870         close(p->fd_out);
2871         sys$dassgn(p->chan_in);
2872         *p->pipe_done = TRUE;
2873         _ckvmssts(sys$setef(pipe_ef));
2874         return;
2875     }
2876
2877     if (!err && !eof) {             /* good data to send to file */
2878         p->buf[p->iosb.count] = '\n';
2879         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2880         if (iss2 < 0) {
2881             p->retry++;
2882             if (p->retry < MAX_RETRY) {
2883                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2884                 return;
2885             }
2886         }
2887         p->retry = 0;
2888     } else if (err) {
2889         _ckvmssts(iss);
2890     }
2891
2892
2893     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2894           pipe_mbxtofd_ast, p,
2895           p->buf, p->bufsize, 0, 0, 0, 0);
2896     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2897     _ckvmssts(iss);
2898 }
2899
2900
2901 typedef struct _pipeloc     PLOC;
2902 typedef struct _pipeloc*   pPLOC;
2903
2904 struct _pipeloc {
2905     pPLOC   next;
2906     char    dir[NAM$C_MAXRSS+1];
2907 };
2908 static pPLOC  head_PLOC = 0;
2909
2910 void
2911 free_pipelocs(pTHX_ void *head)
2912 {
2913     pPLOC p, pnext;
2914     pPLOC *pHead = (pPLOC *)head;
2915
2916     p = *pHead;
2917     while (p) {
2918         pnext = p->next;
2919         PerlMem_free(p);
2920         p = pnext;
2921     }
2922     *pHead = 0;
2923 }
2924
2925 static void
2926 store_pipelocs(pTHX)
2927 {
2928     int    i;
2929     pPLOC  p;
2930     AV    *av = 0;
2931     SV    *dirsv;
2932     GV    *gv;
2933     char  *dir, *x;
2934     char  *unixdir;
2935     char  temp[NAM$C_MAXRSS+1];
2936     STRLEN n_a;
2937
2938     if (head_PLOC)
2939         free_pipelocs(aTHX_ &head_PLOC);
2940
2941 /*  the . directory from @INC comes last */
2942
2943     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2944     p->next = head_PLOC;
2945     head_PLOC = p;
2946     strcpy(p->dir,"./");
2947
2948 /*  get the directory from $^X */
2949
2950 #ifdef PERL_IMPLICIT_CONTEXT
2951     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2952 #else
2953     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2954 #endif
2955         strcpy(temp, PL_origargv[0]);
2956         x = strrchr(temp,']');
2957         if (x == NULL) {
2958         x = strrchr(temp,'>');
2959           if (x == NULL) {
2960             /* It could be a UNIX path */
2961             x = strrchr(temp,'/');
2962           }
2963         }
2964         if (x)
2965           x[1] = '\0';
2966         else {
2967           /* Got a bare name, so use default directory */
2968           temp[0] = '.';
2969           temp[1] = '\0';
2970         }
2971
2972         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2973             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2974             p->next = head_PLOC;
2975             head_PLOC = p;
2976             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2977             p->dir[NAM$C_MAXRSS] = '\0';
2978         }
2979     }
2980
2981 /*  reverse order of @INC entries, skip "." since entered above */
2982
2983 #ifdef PERL_IMPLICIT_CONTEXT
2984     if (aTHX)
2985 #endif
2986     if (PL_incgv) av = GvAVn(PL_incgv);
2987
2988     for (i = 0; av && i <= AvFILL(av); i++) {
2989         dirsv = *av_fetch(av,i,TRUE);
2990
2991         if (SvROK(dirsv)) continue;
2992         dir = SvPVx(dirsv,n_a);
2993         if (strcmp(dir,".") == 0) continue;
2994         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2995             continue;
2996
2997         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2998         p->next = head_PLOC;
2999         head_PLOC = p;
3000         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3001         p->dir[NAM$C_MAXRSS] = '\0';
3002     }
3003
3004 /* most likely spot (ARCHLIB) put first in the list */
3005
3006 #ifdef ARCHLIB_EXP
3007     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
3008         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3009         p->next = head_PLOC;
3010         head_PLOC = p;
3011         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3012         p->dir[NAM$C_MAXRSS] = '\0';
3013     }
3014 #endif
3015 }
3016
3017
3018 static char *
3019 find_vmspipe(pTHX)
3020 {
3021     static int   vmspipe_file_status = 0;
3022     static char  vmspipe_file[NAM$C_MAXRSS+1];
3023
3024     /* already found? Check and use ... need read+execute permission */
3025
3026     if (vmspipe_file_status == 1) {
3027         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3028          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3029             return vmspipe_file;
3030         }
3031         vmspipe_file_status = 0;
3032     }
3033
3034     /* scan through stored @INC, $^X */
3035
3036     if (vmspipe_file_status == 0) {
3037         char file[NAM$C_MAXRSS+1];
3038         pPLOC  p = head_PLOC;
3039
3040         while (p) {
3041             strcpy(file, p->dir);
3042             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3043             file[NAM$C_MAXRSS] = '\0';
3044             p = p->next;
3045
3046             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3047
3048             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3049              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3050                 vmspipe_file_status = 1;
3051                 return vmspipe_file;
3052             }
3053         }
3054         vmspipe_file_status = -1;   /* failed, use tempfiles */
3055     }
3056
3057     return 0;
3058 }
3059
3060 static FILE *
3061 vmspipe_tempfile(pTHX)
3062 {
3063     char file[NAM$C_MAXRSS+1];
3064     FILE *fp;
3065     static int index = 0;
3066     Stat_t s0, s1;
3067     int cmp_result;
3068
3069     /* create a tempfile */
3070
3071     /* we can't go from   W, shr=get to  R, shr=get without
3072        an intermediate vulnerable state, so don't bother trying...
3073
3074        and lib$spawn doesn't shr=put, so have to close the write
3075
3076        So... match up the creation date/time and the FID to
3077        make sure we're dealing with the same file
3078
3079     */
3080
3081     index++;
3082     if (!decc_filename_unix_only) {
3083       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3084       fp = fopen(file,"w");
3085       if (!fp) {
3086         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3087         fp = fopen(file,"w");
3088         if (!fp) {
3089             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3090             fp = fopen(file,"w");
3091         }
3092       }
3093      }
3094      else {
3095       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3096       fp = fopen(file,"w");
3097       if (!fp) {
3098         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3099         fp = fopen(file,"w");
3100         if (!fp) {
3101           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3102           fp = fopen(file,"w");
3103         }
3104       }
3105     }
3106     if (!fp) return 0;  /* we're hosed */
3107
3108     fprintf(fp,"$! 'f$verify(0)'\n");
3109     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3110     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3111     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3112     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3113     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3114     fprintf(fp,"$ perl_del    = \"delete\"\n");
3115     fprintf(fp,"$ pif         = \"if\"\n");
3116     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3117     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3118     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3119     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3120     fprintf(fp,"$!  --- build command line to get max possible length\n");
3121     fprintf(fp,"$c=perl_popen_cmd0\n");
3122     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3123     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3124     fprintf(fp,"$x=perl_popen_cmd3\n");
3125     fprintf(fp,"$c=c+x\n");
3126     fprintf(fp,"$ perl_on\n");
3127     fprintf(fp,"$ 'c'\n");
3128     fprintf(fp,"$ perl_status = $STATUS\n");
3129     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3130     fprintf(fp,"$ perl_exit 'perl_status'\n");
3131     fsync(fileno(fp));
3132
3133     fgetname(fp, file, 1);
3134     fstat(fileno(fp), (struct stat *)&s0);
3135     fclose(fp);
3136
3137     if (decc_filename_unix_only)
3138         do_tounixspec(file, file, 0);
3139     fp = fopen(file,"r","shr=get");
3140     if (!fp) return 0;
3141     fstat(fileno(fp), (struct stat *)&s1);
3142
3143     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3144     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3145         fclose(fp);
3146         return 0;
3147     }
3148
3149     return fp;
3150 }
3151
3152
3153
3154 static PerlIO *
3155 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3156 {
3157     static int handler_set_up = FALSE;
3158     unsigned long int sts, flags = CLI$M_NOWAIT;
3159     /* The use of a GLOBAL table (as was done previously) rendered
3160      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3161      * environment.  Hence we've switched to LOCAL symbol table.
3162      */
3163     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3164     int j, wait = 0, n;
3165     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3166     char in[512], out[512], err[512], mbx[512];
3167     FILE *tpipe = 0;
3168     char tfilebuf[NAM$C_MAXRSS+1];
3169     pInfo info = NULL;
3170     char cmd_sym_name[20];
3171     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3172                                       DSC$K_CLASS_S, symbol};
3173     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3174                                       DSC$K_CLASS_S, 0};
3175     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3176                                       DSC$K_CLASS_S, cmd_sym_name};
3177     struct dsc$descriptor_s *vmscmd;
3178     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3179     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3180     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3181
3182     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3183
3184     /* once-per-program initialization...
3185        note that the SETAST calls and the dual test of pipe_ef
3186        makes sure that only the FIRST thread through here does
3187        the initialization...all other threads wait until it's
3188        done.
3189
3190        Yeah, uglier than a pthread call, it's got all the stuff inline
3191        rather than in a separate routine.
3192     */
3193
3194     if (!pipe_ef) {
3195         _ckvmssts(sys$setast(0));
3196         if (!pipe_ef) {
3197             unsigned long int pidcode = JPI$_PID;
3198             $DESCRIPTOR(d_delay, RETRY_DELAY);
3199             _ckvmssts(lib$get_ef(&pipe_ef));
3200             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3201             _ckvmssts(sys$bintim(&d_delay, delaytime));
3202         }
3203         if (!handler_set_up) {
3204           _ckvmssts(sys$dclexh(&pipe_exitblock));
3205           handler_set_up = TRUE;
3206         }
3207         _ckvmssts(sys$setast(1));
3208     }
3209
3210     /* see if we can find a VMSPIPE.COM */
3211
3212     tfilebuf[0] = '@';
3213     vmspipe = find_vmspipe(aTHX);
3214     if (vmspipe) {
3215         strcpy(tfilebuf+1,vmspipe);
3216     } else {        /* uh, oh...we're in tempfile hell */
3217         tpipe = vmspipe_tempfile(aTHX);
3218         if (!tpipe) {       /* a fish popular in Boston */
3219             if (ckWARN(WARN_PIPE)) {
3220                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3221             }
3222         return Nullfp;
3223         }
3224         fgetname(tpipe,tfilebuf+1,1);
3225     }
3226     vmspipedsc.dsc$a_pointer = tfilebuf;
3227     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3228
3229     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3230     if (!(sts & 1)) {
3231       switch (sts) {
3232         case RMS$_FNF:  case RMS$_DNF:
3233           set_errno(ENOENT); break;
3234         case RMS$_DIR:
3235           set_errno(ENOTDIR); break;
3236         case RMS$_DEV:
3237           set_errno(ENODEV); break;
3238         case RMS$_PRV:
3239           set_errno(EACCES); break;
3240         case RMS$_SYN:
3241           set_errno(EINVAL); break;
3242         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3243           set_errno(E2BIG); break;
3244         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3245           _ckvmssts(sts); /* fall through */
3246         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3247           set_errno(EVMSERR);
3248       }
3249       set_vaxc_errno(sts);
3250       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3251         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3252       }
3253       *psts = sts;
3254       return Nullfp;
3255     }
3256     n = sizeof(Info);
3257     _ckvmssts(lib$get_vm(&n, &info));
3258
3259     strcpy(mode,in_mode);
3260     info->mode = *mode;
3261     info->done = FALSE;
3262     info->completion = 0;
3263     info->closing    = FALSE;
3264     info->in         = 0;
3265     info->out        = 0;
3266     info->err        = 0;
3267     info->fp         = Nullfp;
3268     info->useFILE    = 0;
3269     info->waiting    = 0;
3270     info->in_done    = TRUE;
3271     info->out_done   = TRUE;
3272     info->err_done   = TRUE;
3273     in[0] = out[0] = err[0] = '\0';
3274
3275     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3276         info->useFILE = 1;
3277         strcpy(p,p+1);
3278     }
3279     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3280         wait = 1;
3281         strcpy(p,p+1);
3282     }
3283
3284     if (*mode == 'r') {             /* piping from subroutine */
3285
3286         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3287         if (info->out) {
3288             info->out->pipe_done = &info->out_done;
3289             info->out_done = FALSE;
3290             info->out->info = info;
3291         }
3292         if (!info->useFILE) {
3293         info->fp  = PerlIO_open(mbx, mode);
3294         } else {
3295             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3296             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3297         }
3298
3299         if (!info->fp && info->out) {
3300             sys$cancel(info->out->chan_out);
3301
3302             while (!info->out_done) {
3303                 int done;
3304                 _ckvmssts(sys$setast(0));
3305                 done = info->out_done;
3306                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3307                 _ckvmssts(sys$setast(1));
3308                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3309             }
3310
3311             if (info->out->buf) {
3312                 n = info->out->bufsize * sizeof(char);
3313                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3314             }
3315             n = sizeof(Pipe);
3316             _ckvmssts(lib$free_vm(&n, &info->out));
3317             n = sizeof(Info);
3318             _ckvmssts(lib$free_vm(&n, &info));
3319             *psts = RMS$_FNF;
3320             return Nullfp;
3321         }
3322
3323         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3324         if (info->err) {
3325             info->err->pipe_done = &info->err_done;
3326             info->err_done = FALSE;
3327             info->err->info = info;
3328         }
3329
3330     } else if (*mode == 'w') {      /* piping to subroutine */
3331
3332         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3333         if (info->out) {
3334             info->out->pipe_done = &info->out_done;
3335             info->out_done = FALSE;
3336             info->out->info = info;
3337         }
3338
3339         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3340         if (info->err) {
3341             info->err->pipe_done = &info->err_done;
3342             info->err_done = FALSE;
3343             info->err->info = info;
3344         }
3345
3346         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3347         if (!info->useFILE) {
3348             info->fp  = PerlIO_open(mbx, mode);
3349         } else {
3350             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3351             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3352         }
3353
3354         if (info->in) {
3355             info->in->pipe_done = &info->in_done;
3356             info->in_done = FALSE;
3357             info->in->info = info;
3358         }
3359
3360         /* error cleanup */
3361         if (!info->fp && info->in) {
3362             info->done = TRUE;
3363             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3364                               0, 0, 0, 0, 0, 0, 0, 0));
3365
3366             while (!info->in_done) {
3367                 int done;
3368                 _ckvmssts(sys$setast(0));
3369                 done = info->in_done;
3370                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3371                 _ckvmssts(sys$setast(1));
3372                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3373             }
3374
3375             if (info->in->buf) {
3376                 n = info->in->bufsize * sizeof(char);
3377                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3378             }
3379             n = sizeof(Pipe);
3380             _ckvmssts(lib$free_vm(&n, &info->in));
3381             n = sizeof(Info);
3382             _ckvmssts(lib$free_vm(&n, &info));
3383             *psts = RMS$_FNF;
3384             return Nullfp;
3385         }
3386
3387
3388     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3389         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3390         if (info->out) {
3391             info->out->pipe_done = &info->out_done;
3392             info->out_done = FALSE;
3393             info->out->info = info;
3394         }
3395
3396         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3397         if (info->err) {
3398             info->err->pipe_done = &info->err_done;
3399             info->err_done = FALSE;
3400             info->err->info = info;
3401         }
3402     }
3403
3404     symbol[MAX_DCL_SYMBOL] = '\0';
3405
3406     strncpy(symbol, in, MAX_DCL_SYMBOL);
3407     d_symbol.dsc$w_length = strlen(symbol);
3408     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3409
3410     strncpy(symbol, err, MAX_DCL_SYMBOL);
3411     d_symbol.dsc$w_length = strlen(symbol);
3412     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3413
3414     strncpy(symbol, out, MAX_DCL_SYMBOL);
3415     d_symbol.dsc$w_length = strlen(symbol);
3416     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3417
3418     p = vmscmd->dsc$a_pointer;
3419     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3420     if (*p == '$') p++;                         /* remove leading $ */
3421     while (*p == ' ' || *p == '\t') p++;
3422
3423     for (j = 0; j < 4; j++) {
3424         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3425         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3426
3427     strncpy(symbol, p, MAX_DCL_SYMBOL);
3428     d_symbol.dsc$w_length = strlen(symbol);
3429     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3430
3431         if (strlen(p) > MAX_DCL_SYMBOL) {
3432             p += MAX_DCL_SYMBOL;
3433         } else {
3434             p += strlen(p);
3435         }
3436     }
3437     _ckvmssts(sys$setast(0));
3438     info->next=open_pipes;  /* prepend to list */
3439     open_pipes=info;
3440     _ckvmssts(sys$setast(1));
3441     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3442      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3443      * have SYS$COMMAND if we need it.
3444      */
3445     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3446                       0, &info->pid, &info->completion,
3447                       0, popen_completion_ast,info,0,0,0));
3448
3449     /* if we were using a tempfile, close it now */
3450
3451     if (tpipe) fclose(tpipe);
3452
3453     /* once the subprocess is spawned, it has copied the symbols and
3454        we can get rid of ours */
3455
3456     for (j = 0; j < 4; j++) {
3457         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3458         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3459     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3460     }
3461     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3462     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3463     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3464     vms_execfree(vmscmd);
3465
3466 #ifdef PERL_IMPLICIT_CONTEXT
3467     if (aTHX)
3468 #endif
3469     PL_forkprocess = info->pid;
3470
3471     if (wait) {
3472          int done = 0;
3473          while (!done) {
3474              _ckvmssts(sys$setast(0));
3475              done = info->done;
3476              if (!done) _ckvmssts(sys$clref(pipe_ef));
3477              _ckvmssts(sys$setast(1));
3478              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3479          }
3480         *psts = info->completion;
3481 /* Caller thinks it is open and tries to close it. */
3482 /* This causes some problems, as it changes the error status */
3483 /*        my_pclose(info->fp); */
3484     } else {
3485         *psts = SS$_NORMAL;
3486     }
3487     return info->fp;
3488 }  /* end of safe_popen */
3489
3490
3491 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3492 PerlIO *
3493 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3494 {
3495     int sts;
3496     TAINT_ENV();
3497     TAINT_PROPER("popen");
3498     PERL_FLUSHALL_FOR_CHILD;
3499     return safe_popen(aTHX_ cmd,mode,&sts);
3500 }
3501
3502 /*}}}*/
3503
3504 /*{{{  I32 my_pclose(PerlIO *fp)*/
3505 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3506 {
3507     pInfo info, last = NULL;
3508     unsigned long int retsts;
3509     int done, iss, n;
3510
3511     for (info = open_pipes; info != NULL; last = info, info = info->next)
3512         if (info->fp == fp) break;
3513
3514     if (info == NULL) {  /* no such pipe open */
3515       set_errno(ECHILD); /* quoth POSIX */
3516       set_vaxc_errno(SS$_NONEXPR);
3517       return -1;
3518     }
3519
3520     /* If we were writing to a subprocess, insure that someone reading from
3521      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3522      * produce an EOF record in the mailbox.
3523      *
3524      *  well, at least sometimes it *does*, so we have to watch out for
3525      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3526      */
3527      if (info->fp) {
3528         if (!info->useFILE)
3529             PerlIO_flush(info->fp);   /* first, flush data */
3530         else
3531             fflush((FILE *)info->fp);
3532     }
3533
3534     _ckvmssts(sys$setast(0));
3535      info->closing = TRUE;
3536      done = info->done && info->in_done && info->out_done && info->err_done;
3537      /* hanging on write to Perl's input? cancel it */
3538      if (info->mode == 'r' && info->out && !info->out_done) {
3539         if (info->out->chan_out) {
3540             _ckvmssts(sys$cancel(info->out->chan_out));
3541             if (!info->out->chan_in) {   /* EOF generation, need AST */
3542                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3543             }
3544         }
3545      }
3546      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3547          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3548                            0, 0, 0, 0, 0, 0));
3549     _ckvmssts(sys$setast(1));
3550     if (info->fp) {
3551      if (!info->useFILE)
3552         PerlIO_close(info->fp);
3553      else
3554         fclose((FILE *)info->fp);
3555     }
3556      /*
3557         we have to wait until subprocess completes, but ALSO wait until all
3558         the i/o completes...otherwise we'll be freeing the "info" structure
3559         that the i/o ASTs could still be using...
3560      */
3561
3562      while (!done) {
3563          _ckvmssts(sys$setast(0));
3564          done = info->done && info->in_done && info->out_done && info->err_done;
3565          if (!done) _ckvmssts(sys$clref(pipe_ef));
3566          _ckvmssts(sys$setast(1));
3567          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3568      }
3569      retsts = info->completion;
3570
3571     /* remove from list of open pipes */
3572     _ckvmssts(sys$setast(0));
3573     if (last) last->next = info->next;
3574     else open_pipes = info->next;
3575     _ckvmssts(sys$setast(1));
3576
3577     /* free buffers and structures */
3578
3579     if (info->in) {
3580         if (info->in->buf) {
3581             n = info->in->bufsize * sizeof(char);
3582             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3583         }
3584         n = sizeof(Pipe);
3585         _ckvmssts(lib$free_vm(&n, &info->in));
3586     }
3587     if (info->out) {
3588         if (info->out->buf) {
3589             n = info->out->bufsize * sizeof(char);
3590             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3591         }
3592         n = sizeof(Pipe);
3593         _ckvmssts(lib$free_vm(&n, &info->out));
3594     }
3595     if (info->err) {
3596         if (info->err->buf) {
3597             n = info->err->bufsize * sizeof(char);
3598             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3599         }
3600         n = sizeof(Pipe);
3601         _ckvmssts(lib$free_vm(&n, &info->err));
3602     }
3603     n = sizeof(Info);
3604     _ckvmssts(lib$free_vm(&n, &info));
3605
3606     return retsts;
3607
3608 }  /* end of my_pclose() */
3609
3610 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3611   /* Roll our own prototype because we want this regardless of whether
3612    * _VMS_WAIT is defined.
3613    */
3614   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3615 #endif
3616 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3617    created with popen(); otherwise partially emulate waitpid() unless
3618    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3619    Also check processes not considered by the CRTL waitpid().
3620  */
3621 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3622 Pid_t
3623 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3624 {
3625     pInfo info;
3626     int done;
3627     int sts;
3628     int j;
3629
3630     if (statusp) *statusp = 0;
3631
3632     for (info = open_pipes; info != NULL; info = info->next)
3633         if (info->pid == pid) break;
3634
3635     if (info != NULL) {  /* we know about this child */
3636       while (!info->done) {
3637           _ckvmssts(sys$setast(0));
3638           done = info->done;
3639           if (!done) _ckvmssts(sys$clref(pipe_ef));
3640           _ckvmssts(sys$setast(1));
3641           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3642       }
3643
3644       if (statusp) *statusp = info->completion;
3645       return pid;
3646     }
3647
3648     /* child that already terminated? */
3649
3650     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3651         if (closed_list[j].pid == pid) {
3652             if (statusp) *statusp = closed_list[j].completion;
3653             return pid;
3654         }
3655     }
3656
3657     /* fall through if this child is not one of our own pipe children */
3658
3659 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3660
3661       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3662        * in 7.2 did we get a version that fills in the VMS completion
3663        * status as Perl has always tried to do.
3664        */
3665
3666       sts = __vms_waitpid( pid, statusp, flags );
3667
3668       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3669          return sts;
3670
3671       /* If the real waitpid tells us the child does not exist, we
3672        * fall through here to implement waiting for a child that
3673        * was created by some means other than exec() (say, spawned
3674        * from DCL) or to wait for a process that is not a subprocess
3675        * of the current process.
3676        */
3677
3678 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3679
3680     {
3681       $DESCRIPTOR(intdsc,"0 00:00:01");
3682       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3683       unsigned long int pidcode = JPI$_PID, mypid;
3684       unsigned long int interval[2];
3685       unsigned int jpi_iosb[2];
3686       struct itmlst_3 jpilist[2] = {
3687           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3688           {                      0,         0,                 0, 0}
3689       };
3690
3691       if (pid <= 0) {
3692         /* Sorry folks, we don't presently implement rooting around for
3693            the first child we can find, and we definitely don't want to
3694            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3695          */
3696         set_errno(ENOTSUP);
3697         return -1;
3698       }
3699
3700       /* Get the owner of the child so I can warn if it's not mine. If the
3701        * process doesn't exist or I don't have the privs to look at it,
3702        * I can go home early.
3703        */
3704       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3705       if (sts & 1) sts = jpi_iosb[0];
3706       if (!(sts & 1)) {
3707         switch (sts) {
3708             case SS$_NONEXPR:
3709                 set_errno(ECHILD);
3710                 break;
3711             case SS$_NOPRIV:
3712                 set_errno(EACCES);
3713                 break;
3714             default:
3715                 _ckvmssts(sts);
3716         }
3717         set_vaxc_errno(sts);
3718         return -1;
3719       }
3720
3721       if (ckWARN(WARN_EXEC)) {
3722         /* remind folks they are asking for non-standard waitpid behavior */
3723         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3724         if (ownerpid != mypid)
3725           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3726                       "waitpid: process %x is not a child of process %x",
3727                       pid,mypid);
3728       }
3729
3730       /* simply check on it once a second until it's not there anymore. */
3731
3732       _ckvmssts(sys$bintim(&intdsc,interval));
3733       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3734             _ckvmssts(sys$schdwk(0,0,interval,0));
3735             _ckvmssts(sys$hiber());
3736       }
3737       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3738
3739       _ckvmssts(sts);
3740       return pid;
3741     }
3742 }  /* end of waitpid() */
3743 /*}}}*/
3744 /*}}}*/
3745 /*}}}*/
3746
3747 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3748 char *
3749 my_gconvert(double val, int ndig, int trail, char *buf)
3750 {
3751   static char __gcvtbuf[DBL_DIG+1];
3752   char *loc;
3753
3754   loc = buf ? buf : __gcvtbuf;
3755
3756 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3757   if (val < 1) {
3758     sprintf(loc,"%.*g",ndig,val);
3759     return loc;
3760   }
3761 #endif
3762
3763   if (val) {
3764     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3765     return gcvt(val,ndig,loc);
3766   }
3767   else {
3768     loc[0] = '0'; loc[1] = '\0';
3769     return loc;
3770   }
3771
3772 }
3773 /*}}}*/
3774
3775 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3776 static int rms_free_search_context(struct FAB * fab)
3777 {
3778 struct NAM * nam;
3779
3780     nam = fab->fab$l_nam;
3781     nam->nam$b_nop |= NAM$M_SYNCHK;
3782     nam->nam$l_rlf = NULL;
3783     fab->fab$b_dns = 0;
3784     return sys$parse(fab, NULL, NULL);
3785 }
3786
3787 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3788 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3789 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3790 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3791 #define rms_nam_esll(nam) nam.nam$b_esl
3792 #define rms_nam_esl(nam) nam.nam$b_esl
3793 #define rms_nam_name(nam) nam.nam$l_name
3794 #define rms_nam_namel(nam) nam.nam$l_name
3795 #define rms_nam_type(nam) nam.nam$l_type
3796 #define rms_nam_typel(nam) nam.nam$l_type
3797 #define rms_nam_ver(nam) nam.nam$l_ver
3798 #define rms_nam_verl(nam) nam.nam$l_ver
3799 #define rms_nam_rsll(nam) nam.nam$b_rsl
3800 #define rms_nam_rsl(nam) nam.nam$b_rsl
3801 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3802 #define rms_set_fna(fab, nam, name, size) \
3803         fab.fab$b_fns = size; fab.fab$l_fna = name;
3804 #define rms_get_fna(fab, nam) fab.fab$l_fna
3805 #define rms_set_dna(fab, nam, name, size) \
3806         fab.fab$b_dns = size; fab.fab$l_dna = name;
3807 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3808 #define rms_set_esa(fab, nam, name, size) \
3809         nam.nam$b_ess = size; nam.nam$l_esa = name;
3810 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3811         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3812 #define rms_set_rsa(nam, name, size) \
3813         nam.nam$l_rsa = name; nam.nam$b_rss = size;
3814 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3815         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3816
3817 #else
3818 static int rms_free_search_context(struct FAB * fab)
3819 {
3820 struct NAML * nam;
3821
3822     nam = fab->fab$l_naml;
3823     nam->naml$b_nop |= NAM$M_SYNCHK;
3824     nam->naml$l_rlf = NULL;
3825     nam->naml$l_long_defname_size = 0;
3826     fab->fab$b_dns = 0;
3827     return sys$parse(fab, NULL, NULL);
3828 }
3829
3830 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3831 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3832 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3833 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3834 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3835 #define rms_nam_esl(nam) nam.naml$b_esl
3836 #define rms_nam_name(nam) nam.naml$l_name
3837 #define rms_nam_namel(nam) nam.naml$l_long_name
3838 #define rms_nam_type(nam) nam.naml$l_type
3839 #define rms_nam_typel(nam) nam.naml$l_long_type
3840 #define rms_nam_ver(nam) nam.naml$l_ver
3841 #define rms_nam_verl(nam) nam.naml$l_long_ver
3842 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3843 #define rms_nam_rsl(nam) nam.naml$b_rsl
3844 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3845 #define rms_set_fna(fab, nam, name, size) \
3846         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3847         nam.naml$l_long_filename_size = size; \
3848         nam.naml$l_long_filename = name
3849 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3850 #define rms_set_dna(fab, nam, name, size) \
3851         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3852         nam.naml$l_long_defname_size = size; \
3853         nam.naml$l_long_defname = name
3854 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3855 #define rms_set_esa(fab, nam, name, size) \
3856         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3857         nam.naml$l_long_expand_alloc = size; \
3858         nam.naml$l_long_expand = name
3859 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3860         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3861         nam.naml$l_long_expand = l_name; \
3862         nam.naml$l_long_expand_alloc = l_size;
3863 #define rms_set_rsa(nam, name, size) \
3864         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3865         nam.naml$l_long_result = name; \
3866         nam.naml$l_long_result_alloc = size;
3867 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3868         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3869         nam.naml$l_long_result = l_name; \
3870         nam.naml$l_long_result_alloc = l_size;
3871
3872 #endif
3873
3874
3875 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3876 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3877  * to expand file specification.  Allows for a single default file
3878  * specification and a simple mask of options.  If outbuf is non-NULL,
3879  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3880  * the resultant file specification is placed.  If outbuf is NULL, the
3881  * resultant file specification is placed into a static buffer.
3882  * The third argument, if non-NULL, is taken to be a default file
3883  * specification string.  The fourth argument is unused at present.
3884  * rmesexpand() returns the address of the resultant string if
3885  * successful, and NULL on error.
3886  *
3887  * New functionality for previously unused opts value:
3888  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3889  */
3890 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3891
3892 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3893 /* ODS-2 only version */
3894 static char *
3895 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3896 {
3897   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3898   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3899   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3900   struct FAB myfab = cc$rms_fab;
3901   struct NAM mynam = cc$rms_nam;
3902   STRLEN speclen;
3903   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3904   int sts;
3905
3906   if (!filespec || !*filespec) {
3907     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3908     return NULL;
3909   }
3910   if (!outbuf) {
3911     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3912     else    outbuf = __rmsexpand_retbuf;
3913   }
3914   isunix = is_unix_filespec(filespec);
3915   if (isunix) {
3916     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3917         if (out)
3918            Safefree(out);
3919         return NULL;
3920     }
3921     filespec = vmsfspec;
3922   }
3923
3924   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3925   myfab.fab$b_fns = strlen(filespec);
3926   myfab.fab$l_nam = &mynam;
3927
3928   if (defspec && *defspec) {
3929     if (strchr(defspec,'/') != NULL) {
3930       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3931         if (out)
3932            Safefree(out);
3933         return NULL;
3934       }
3935       defspec = tmpfspec;
3936     }
3937     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3938     myfab.fab$b_dns = strlen(defspec);
3939   }
3940
3941   mynam.nam$l_esa = esa;
3942   mynam.nam$b_ess = sizeof esa;
3943   mynam.nam$l_rsa = outbuf;
3944   mynam.nam$b_rss = NAM$C_MAXRSS;
3945
3946 #ifdef NAM$M_NO_SHORT_UPCASE
3947   if (decc_efs_case_preserve)
3948     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3949 #endif
3950
3951   retsts = sys$parse(&myfab,0,0);
3952   if (!(retsts & 1)) {
3953     mynam.nam$b_nop |= NAM$M_SYNCHK;
3954     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3955       retsts = sys$parse(&myfab,0,0);
3956       if (retsts & 1) goto expanded;
3957     }
3958     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3959     sts = sys$parse(&myfab,0,0);  /* Free search context */
3960     if (out) Safefree(out);
3961     set_vaxc_errno(retsts);
3962     if      (retsts == RMS$_PRV) set_errno(EACCES);
3963     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3964     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3965     else                         set_errno(EVMSERR);
3966     return NULL;
3967   }
3968   retsts = sys$search(&myfab,0,0);
3969   if (!(retsts & 1) && retsts != RMS$_FNF) {
3970     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3971     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3972     if (out) Safefree(out);
3973     set_vaxc_errno(retsts);
3974     if      (retsts == RMS$_PRV) set_errno(EACCES);
3975     else                         set_errno(EVMSERR);
3976     return NULL;
3977   }
3978
3979   /* If the input filespec contained any lowercase characters,
3980    * downcase the result for compatibility with Unix-minded code. */
3981   expanded:
3982   if (!decc_efs_case_preserve) {
3983     for (out = myfab.fab$l_fna; *out; out++)
3984       if (islower(*out)) { haslower = 1; break; }
3985   }
3986   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3987   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3988   /* Trim off null fields added by $PARSE
3989    * If type > 1 char, must have been specified in original or default spec
3990    * (not true for version; $SEARCH may have added version of existing file).
3991    */
3992   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3993   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3994              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3995   if (trimver || trimtype) {
3996     if (defspec && *defspec) {
3997       char defesa[NAM$C_MAXRSS];
3998       struct FAB deffab = cc$rms_fab;
3999       struct NAM defnam = cc$rms_nam;
4000
4001       deffab.fab$l_nam = &defnam;
4002       /* cast below ok for read only pointer */
4003       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
4004       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
4005       defnam.nam$b_nop = NAM$M_SYNCHK;
4006 #ifdef NAM$M_NO_SHORT_UPCASE
4007       if (decc_efs_case_preserve)
4008         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4009 #endif
4010       if (sys$parse(&deffab,0,0) & 1) {
4011         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4012         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4013       }
4014     }
4015     if (trimver) {
4016       if (*mynam.nam$l_ver != '\"')
4017         speclen = mynam.nam$l_ver - out;
4018     }
4019     if (trimtype) {
4020       /* If we didn't already trim version, copy down */
4021       if (speclen > mynam.nam$l_ver - out)
4022         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4023                speclen - (mynam.nam$l_ver - out));
4024       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4025     }
4026   }
4027   /* If we just had a directory spec on input, $PARSE "helpfully"
4028    * adds an empty name and type for us */
4029   if (mynam.nam$l_name == mynam.nam$l_type &&
4030       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4031       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4032     speclen = mynam.nam$l_name - out;
4033
4034   /* Posix format specifications must have matching quotes */
4035   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4036     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4037       out[speclen] = '\"';
4038       speclen++;
4039     }
4040   }
4041
4042   out[speclen] = '\0';
4043   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4044
4045   /* Have we been working with an expanded, but not resultant, spec? */
4046   /* Also, convert back to Unix syntax if necessary. */
4047   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4048     isunix = 0;
4049
4050   if (!mynam.nam$b_rsl) {
4051     if (isunix) {
4052       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4053     }
4054     else strcpy(outbuf,esa);
4055   }
4056   else if (isunix) {
4057     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4058     strcpy(outbuf,tmpfspec);
4059   }
4060   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4061   mynam.nam$l_rsa = NULL;
4062   mynam.nam$b_rss = 0;
4063   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4064   return outbuf;
4065 }
4066 #else
4067 /* ODS-5 supporting routine */
4068 static char *
4069 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4070 {
4071   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4072   char * vmsfspec, *tmpfspec;
4073   char * esa, *cp, *out = NULL;
4074   char * esal;
4075   char * outbufl;
4076   struct FAB myfab = cc$rms_fab;
4077   rms_setup_nam(mynam);
4078   STRLEN speclen;
4079   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4080   int sts;
4081
4082   if (!filespec || !*filespec) {
4083     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4084     return NULL;
4085   }
4086   if (!outbuf) {
4087     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4088     else    outbuf = __rmsexpand_retbuf;
4089   }
4090
4091   vmsfspec = NULL;
4092   tmpfspec = NULL;
4093   outbufl = NULL;
4094   isunix = is_unix_filespec(filespec);
4095   if (isunix) {
4096     Newx(vmsfspec, VMS_MAXRSS, char);
4097     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4098         Safefree(vmsfspec);
4099         if (out)
4100            Safefree(out);
4101         return NULL;
4102     }
4103     filespec = vmsfspec;
4104
4105      /* Unless we are forcing to VMS format, a UNIX input means
4106       * UNIX output, and that requires long names to be used
4107       */
4108     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4109         opts |= PERL_RMSEXPAND_M_LONG;
4110     else {
4111         isunix = 0;
4112     }
4113   }
4114
4115   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4116   rms_bind_fab_nam(myfab, mynam);
4117
4118   if (defspec && *defspec) {
4119     int t_isunix;
4120     t_isunix = is_unix_filespec(defspec);
4121     if (t_isunix) {
4122       Newx(tmpfspec, VMS_MAXRSS, char);
4123       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4124         Safefree(tmpfspec);
4125         if (vmsfspec != NULL)
4126             Safefree(vmsfspec);
4127         if (out)
4128            Safefree(out);
4129         return NULL;
4130       }
4131       defspec = tmpfspec;
4132     }
4133     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4134   }
4135
4136   Newx(esa, NAM$C_MAXRSS + 1, char);
4137 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4138   Newx(esal, NAML$C_MAXRSS + 1, char);
4139 #endif
4140   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4141
4142   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4143     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4144   }
4145   else {
4146 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4147     Newx(outbufl, VMS_MAXRSS, char);
4148     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4149 #else
4150     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4151 #endif
4152   }
4153
4154 #ifdef NAM$M_NO_SHORT_UPCASE
4155   if (decc_efs_case_preserve)
4156     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4157 #endif
4158
4159   /* First attempt to parse as an existing file */
4160   retsts = sys$parse(&myfab,0,0);
4161   if (!(retsts & STS$K_SUCCESS)) {
4162
4163     /* Could not find the file, try as syntax only if error is not fatal */
4164     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4165     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4166       retsts = sys$parse(&myfab,0,0);
4167       if (retsts & STS$K_SUCCESS) goto expanded;
4168     }
4169
4170      /* Still could not parse the file specification */
4171     /*----------------------------------------------*/
4172     sts = rms_free_search_context(&myfab); /* Free search context */
4173     if (out) Safefree(out);
4174     if (tmpfspec != NULL)
4175         Safefree(tmpfspec);
4176     if (vmsfspec != NULL)
4177         Safefree(vmsfspec);
4178     Safefree(esa);
4179     Safefree(esal);
4180     set_vaxc_errno(retsts);
4181     if      (retsts == RMS$_PRV) set_errno(EACCES);
4182     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4183     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4184     else                         set_errno(EVMSERR);
4185     return NULL;
4186   }
4187   retsts = sys$search(&myfab,0,0);
4188   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4189     sts = rms_free_search_context(&myfab); /* Free search context */
4190     if (out) Safefree(out);
4191     if (tmpfspec != NULL)
4192         Safefree(tmpfspec);
4193     if (vmsfspec != NULL)
4194         Safefree(vmsfspec);
4195     Safefree(esa);
4196     Safefree(esal);
4197     set_vaxc_errno(retsts);
4198     if      (retsts == RMS$_PRV) set_errno(EACCES);
4199     else                         set_errno(EVMSERR);
4200     return NULL;
4201   }
4202
4203   /* If the input filespec contained any lowercase characters,
4204    * downcase the result for compatibility with Unix-minded code. */
4205   expanded:
4206   if (!decc_efs_case_preserve) {
4207     for (out = rms_get_fna(myfab, mynam); *out; out++)
4208       if (islower(*out)) { haslower = 1; break; }
4209   }
4210
4211    /* Is a long or a short name expected */
4212   /*------------------------------------*/
4213   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4214     if (rms_nam_rsll(mynam)) {
4215         out = outbuf;
4216         speclen = rms_nam_rsll(mynam);
4217     }
4218     else {
4219         out = esal; /* Not esa */
4220         speclen = rms_nam_esll(mynam);
4221     }
4222   }
4223   else {
4224     if (rms_nam_rsl(mynam)) {
4225         out = outbuf;
4226         speclen = rms_nam_rsl(mynam);
4227     }
4228     else {
4229         out = esa; /* Not esal */
4230         speclen = rms_nam_esl(mynam);
4231     }
4232   }
4233   /* Trim off null fields added by $PARSE
4234    * If type > 1 char, must have been specified in original or default spec
4235    * (not true for version; $SEARCH may have added version of existing file).
4236    */
4237   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4238   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4239     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4240              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4241   }
4242   else {
4243     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4244              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4245   }
4246   if (trimver || trimtype) {
4247     if (defspec && *defspec) {
4248       char *defesal = NULL;
4249       Newx(defesal, NAML$C_MAXRSS + 1, char);
4250       if (defesal != NULL) {
4251         struct FAB deffab = cc$rms_fab;
4252         rms_setup_nam(defnam);
4253
4254         rms_bind_fab_nam(deffab, defnam);
4255
4256         /* Cast ok */
4257         rms_set_fna
4258             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4259
4260         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4261
4262         rms_set_nam_nop(defnam, 0);
4263         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4264 #ifdef NAM$M_NO_SHORT_UPCASE
4265         if (decc_efs_case_preserve)
4266           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4267 #endif
4268         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4269           if (trimver) {
4270              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4271           }
4272           if (trimtype) {
4273             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4274           }
4275         }
4276         Safefree(defesal);
4277       }
4278     }
4279     if (trimver) {
4280       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4281         if (*(rms_nam_verl(mynam)) != '\"')
4282           speclen = rms_nam_verl(mynam) - out;
4283       }
4284       else {
4285         if (*(rms_nam_ver(mynam)) != '\"')
4286           speclen = rms_nam_ver(mynam) - out;
4287       }
4288     }
4289     if (trimtype) {
4290       /* If we didn't already trim version, copy down */
4291       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4292         if (speclen > rms_nam_verl(mynam) - out)
4293           memmove
4294            (rms_nam_typel(mynam),
4295             rms_nam_verl(mynam),
4296             speclen - (rms_nam_verl(mynam) - out));
4297           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4298       }
4299       else {
4300         if (speclen > rms_nam_ver(mynam) - out)
4301           memmove
4302            (rms_nam_type(mynam),
4303             rms_nam_ver(mynam),
4304             speclen - (rms_nam_ver(mynam) - out));
4305           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4306       }
4307     }
4308   }
4309
4310    /* Done with these copies of the input files */
4311   /*-------------------------------------------*/
4312   if (vmsfspec != NULL)
4313         Safefree(vmsfspec);
4314   if (tmpfspec != NULL)
4315         Safefree(tmpfspec);
4316
4317   /* If we just had a directory spec on input, $PARSE "helpfully"
4318    * adds an empty name and type for us */
4319   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4320     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4321         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4322         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4323       speclen = rms_nam_namel(mynam) - out;
4324   }
4325   else {
4326     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4327         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4328         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4329       speclen = rms_nam_name(mynam) - out;
4330   }
4331
4332   /* Posix format specifications must have matching quotes */
4333   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4334     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4335       out[speclen] = '\"';
4336       speclen++;
4337     }
4338   }
4339   out[speclen] = '\0';
4340   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4341
4342   /* Have we been working with an expanded, but not resultant, spec? */
4343   /* Also, convert back to Unix syntax if necessary. */
4344
4345   if (!rms_nam_rsll(mynam)) {
4346     if (isunix) {
4347       if (do_tounixspec(esa,outbuf,0) == NULL) {
4348         Safefree(esal);
4349         Safefree(esa);
4350         return NULL;
4351       }
4352     }
4353     else strcpy(outbuf,esa);
4354   }
4355   else if (isunix) {
4356     Newx(tmpfspec, VMS_MAXRSS, char);
4357     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4358         Safefree(esa);
4359         Safefree(esal);
4360         Safefree(tmpfspec);
4361         return NULL;
4362     }
4363     strcpy(outbuf,tmpfspec);
4364     Safefree(tmpfspec);
4365   }
4366
4367   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4368   sts = rms_free_search_context(&myfab); /* Free search context */
4369   Safefree(esa);
4370   Safefree(esal);
4371   return outbuf;
4372 }
4373 #endif
4374 /*}}}*/
4375 /* External entry points */
4376 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4377 { return do_rmsexpand(spec,buf,0,def,opt); }
4378 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4379 { return do_rmsexpand(spec,buf,1,def,opt); }
4380
4381
4382 /*
4383 ** The following routines are provided to make life easier when
4384 ** converting among VMS-style and Unix-style directory specifications.
4385 ** All will take input specifications in either VMS or Unix syntax. On
4386 ** failure, all return NULL.  If successful, the routines listed below
4387 ** return a pointer to a buffer containing the appropriately
4388 ** reformatted spec (and, therefore, subsequent calls to that routine
4389 ** will clobber the result), while the routines of the same names with
4390 ** a _ts suffix appended will return a pointer to a mallocd string
4391 ** containing the appropriately reformatted spec.
4392 ** In all cases, only explicit syntax is altered; no check is made that
4393 ** the resulting string is valid or that the directory in question
4394 ** actually exists.
4395 **
4396 **   fileify_dirspec() - convert a directory spec into the name of the
4397 **     directory file (i.e. what you can stat() to see if it's a dir).
4398 **     The style (VMS or Unix) of the result is the same as the style
4399 **     of the parameter passed in.
4400 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4401 **     what you prepend to a filename to indicate what directory it's in).
4402 **     The style (VMS or Unix) of the result is the same as the style
4403 **     of the parameter passed in.
4404 **   tounixpath() - convert a directory spec into a Unix-style path.
4405 **   tovmspath() - convert a directory spec into a VMS-style path.
4406 **   tounixspec() - convert any file spec into a Unix-style file spec.
4407 **   tovmsspec() - convert any file spec into a VMS-style spec.
4408 **
4409 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4410 ** Permission is given to distribute this code as part of the Perl
4411 ** standard distribution under the terms of the GNU General Public
4412 ** License or the Perl Artistic License.  Copies of each may be
4413 ** found in the Perl standard distribution.
4414  */
4415
4416 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4417 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4418 {
4419     static char __fileify_retbuf[VMS_MAXRSS];
4420     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4421     char *retspec, *cp1, *cp2, *lastdir;
4422     char *trndir, *vmsdir;
4423     unsigned short int trnlnm_iter_count;
4424     int sts;
4425
4426     if (!dir || !*dir) {
4427       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4428     }
4429     dirlen = strlen(dir);
4430     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4431     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4432       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4433         dir = "/sys$disk";
4434         dirlen = 9;
4435       }
4436       else
4437         dirlen = 1;
4438     }
4439     if (dirlen > (VMS_MAXRSS - 1)) {
4440       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4441       return NULL;
4442     }
4443     Newx(trndir, VMS_MAXRSS + 1, char);
4444     if (!strpbrk(dir+1,"/]>:")  &&
4445         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4446       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4447       trnlnm_iter_count = 0;
4448       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4449         trnlnm_iter_count++;
4450         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4451       }
4452       dirlen = strlen(trndir);
4453     }
4454     else {
4455       strncpy(trndir,dir,dirlen);
4456       trndir[dirlen] = '\0';
4457     }
4458
4459     /* At this point we are done with *dir and use *trndir which is a
4460      * copy that can be modified.  *dir must not be modified.
4461      */
4462
4463     /* If we were handed a rooted logical name or spec, treat it like a
4464      * simple directory, so that
4465      *    $ Define myroot dev:[dir.]
4466      *    ... do_fileify_dirspec("myroot",buf,1) ...
4467      * does something useful.
4468      */
4469     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4470       trndir[--dirlen] = '\0';
4471       trndir[dirlen-1] = ']';
4472     }
4473     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4474       trndir[--dirlen] = '\0';
4475       trndir[dirlen-1] = '>';
4476     }
4477
4478     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4479       /* If we've got an explicit filename, we can just shuffle the string. */
4480       if (*(cp1+1)) hasfilename = 1;
4481       /* Similarly, we can just back up a level if we've got multiple levels
4482          of explicit directories in a VMS spec which ends with directories. */
4483       else {
4484         for (cp2 = cp1; cp2 > trndir; cp2--) {
4485           if (*cp2 == '.') {
4486             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4487               *cp2 = *cp1; *cp1 = '\0';
4488               hasfilename = 1;
4489               break;
4490             }
4491           }
4492           if (*cp2 == '[' || *cp2 == '<') break;
4493         }
4494       }
4495     }
4496
4497     Newx(vmsdir, VMS_MAXRSS + 1, char);
4498     cp1 = strpbrk(trndir,"]:>");
4499     if (hasfilename || !cp1) { /* Unix-style path or filename */
4500       if (trndir[0] == '.') {
4501         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4502           Safefree(trndir);
4503           Safefree(vmsdir);
4504           return do_fileify_dirspec("[]",buf,ts);
4505         }
4506         else if (trndir[1] == '.' &&
4507                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4508           Safefree(trndir);
4509           Safefree(vmsdir);
4510           return do_fileify_dirspec("[-]",buf,ts);
4511         }
4512       }
4513       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4514         dirlen -= 1;                 /* to last element */
4515         lastdir = strrchr(trndir,'/');
4516       }
4517       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4518         /* If we have "/." or "/..", VMSify it and let the VMS code
4519          * below expand it, rather than repeating the code to handle
4520          * relative components of a filespec here */
4521         do {
4522           if (*(cp1+2) == '.') cp1++;
4523           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4524             char * ret_chr;
4525             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4526                 Safefree(trndir);
4527                 Safefree(vmsdir);
4528                 return NULL;
4529             }
4530             if (strchr(vmsdir,'/') != NULL) {
4531               /* If do_tovmsspec() returned it, it must have VMS syntax
4532                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4533                * the time to check this here only so we avoid a recursion
4534                * loop; otherwise, gigo.
4535                */
4536               Safefree(trndir);
4537               Safefree(vmsdir);
4538               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4539               return NULL;
4540             }
4541             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4542                 Safefree(trndir);
4543                 Safefree(vmsdir);
4544                 return NULL;
4545             }
4546             ret_chr = do_tounixspec(trndir,buf,ts);
4547             Safefree(trndir);
4548             Safefree(vmsdir);
4549             return ret_chr;
4550           }
4551           cp1++;
4552         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4553         lastdir = strrchr(trndir,'/');
4554       }
4555       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4556         char * ret_chr;
4557         /* Ditto for specs that end in an MFD -- let the VMS code
4558          * figure out whether it's a real device or a rooted logical. */
4559
4560         /* This should not happen any more.  Allowing the fake /000000
4561          * in a UNIX pathname causes all sorts of problems when trying
4562          * to run in UNIX emulation.  So the VMS to UNIX conversions
4563          * now remove the fake /000000 directories.
4564          */
4565
4566         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4567         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4568             Safefree(trndir);
4569             Safefree(vmsdir);
4570             return NULL;
4571         }
4572         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4573             Safefree(trndir);
4574             Safefree(vmsdir);
4575             return NULL;
4576         }
4577         ret_chr = do_tounixspec(trndir,buf,ts);
4578         Safefree(trndir);
4579         Safefree(vmsdir);
4580         return ret_chr;
4581       }
4582       else {
4583
4584         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4585              !(lastdir = cp1 = strrchr(trndir,']')) &&
4586              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4587         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4588           int ver; char *cp3;
4589
4590           /* For EFS or ODS-5 look for the last dot */
4591           if (decc_efs_charset) {
4592               cp2 = strrchr(cp1,'.');
4593           }
4594           if (vms_process_case_tolerant) {
4595               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4596                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4597                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4598                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4599                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4600                             (ver || *cp3)))))) {
4601                   Safefree(trndir);
4602                   Safefree(vmsdir);
4603                   set_errno(ENOTDIR);
4604                   set_vaxc_errno(RMS$_DIR);
4605                   return NULL;
4606               }
4607           }
4608           else {
4609               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4610                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4611                   !*(cp2+3) || *(cp2+3) != 'R' ||
4612                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4613                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4614                             (ver || *cp3)))))) {
4615                  Safefree(trndir);
4616                  Safefree(vmsdir);
4617                  set_errno(ENOTDIR);
4618                  set_vaxc_errno(RMS$_DIR);
4619                  return NULL;
4620               }
4621           }
4622           dirlen = cp2 - trndir;
4623         }
4624       }
4625
4626       retlen = dirlen + 6;
4627       if (buf) retspec = buf;
4628       else if (ts) Newx(retspec,retlen+1,char);
4629       else retspec = __fileify_retbuf;
4630       memcpy(retspec,trndir,dirlen);
4631       retspec[dirlen] = '\0';
4632
4633       /* We've picked up everything up to the directory file name.
4634          Now just add the type and version, and we're set. */
4635       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4636         strcat(retspec,".dir;1");
4637       else
4638         strcat(retspec,".DIR;1");
4639       Safefree(trndir);
4640       Safefree(vmsdir);
4641       return retspec;
4642     }
4643     else {  /* VMS-style directory spec */
4644
4645       char *esa, term, *cp;
4646       unsigned long int sts, cmplen, haslower = 0;
4647       unsigned int nam_fnb;
4648       char * nam_type;
4649       struct FAB dirfab = cc$rms_fab;
4650       rms_setup_nam(savnam);
4651       rms_setup_nam(dirnam);
4652
4653       Newx(esa, VMS_MAXRSS + 1, char);
4654       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4655       rms_bind_fab_nam(dirfab, dirnam);
4656       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4657       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4658 #ifdef NAM$M_NO_SHORT_UPCASE
4659       if (decc_efs_case_preserve)
4660         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4661 #endif
4662
4663       for (cp = trndir; *cp; cp++)
4664         if (islower(*cp)) { haslower = 1; break; }
4665       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4666         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4667           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4668           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4669         }
4670         if (!sts) {
4671           Safefree(esa);
4672           Safefree(trndir);
4673           Safefree(vmsdir);
4674           set_errno(EVMSERR);
4675           set_vaxc_errno(dirfab.fab$l_sts);
4676           return NULL;
4677         }
4678       }
4679       else {
4680         savnam = dirnam;
4681         /* Does the file really exist? */
4682         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4683           /* Yes; fake the fnb bits so we'll check type below */
4684         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4685         }
4686         else { /* No; just work with potential name */
4687           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4688           else {
4689             Safefree(esa);
4690             Safefree(trndir);
4691             Safefree(vmsdir);
4692             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4693             sts = rms_free_search_context(&dirfab);
4694             return NULL;
4695           }
4696         }
4697       }
4698       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4699         cp1 = strchr(esa,']');
4700         if (!cp1) cp1 = strchr(esa,'>');
4701         if (cp1) {  /* Should always be true */
4702           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4703           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4704         }
4705       }
4706       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4707         /* Yep; check version while we're at it, if it's there. */
4708         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4709         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4710           /* Something other than .DIR[;1].  Bzzt. */
4711           sts = rms_free_search_context(&dirfab);
4712           Safefree(esa);
4713           Safefree(trndir);
4714           Safefree(vmsdir);
4715           set_errno(ENOTDIR);
4716           set_vaxc_errno(RMS$_DIR);
4717           return NULL;
4718         }
4719       }
4720       esa[rms_nam_esll(dirnam)] = '\0';
4721       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4722         /* They provided at least the name; we added the type, if necessary, */
4723         if (buf) retspec = buf;                            /* in sys$parse() */
4724         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4725         else retspec = __fileify_retbuf;
4726         strcpy(retspec,esa);
4727         sts = rms_free_search_context(&dirfab);
4728         Safefree(trndir);
4729         Safefree(esa);
4730         Safefree(vmsdir);
4731         return retspec;
4732       }
4733       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4734         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4735         *cp1 = '\0';
4736         rms_nam_esll(dirnam) -= 9;
4737       }
4738       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4739       if (cp1 == NULL) { /* should never happen */
4740         sts = rms_free_search_context(&dirfab);
4741         Safefree(trndir);
4742         Safefree(esa);
4743         Safefree(vmsdir);
4744         return NULL;
4745       }
4746       term = *cp1;
4747       *cp1 = '\0';
4748       retlen = strlen(esa);
4749       cp1 = strrchr(esa,'.');
4750       /* ODS-5 directory specifications can have extra "." in them. */
4751       while (cp1 != NULL) {
4752         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4753           break;
4754         else {
4755            cp1--;
4756            while ((cp1 > esa) && (*cp1 != '.'))
4757              cp1--;
4758         }
4759         if (cp1 == esa)
4760           cp1 = NULL;
4761       }
4762
4763       if ((cp1) != NULL) {
4764         /* There's more than one directory in the path.  Just roll back. */
4765         *cp1 = term;
4766         if (buf) retspec = buf;
4767         else if (ts) Newx(retspec,retlen+7,char);
4768         else retspec = __fileify_retbuf;
4769         strcpy(retspec,esa);
4770       }
4771       else {
4772         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4773           /* Go back and expand rooted logical name */
4774           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4775 #ifdef NAM$M_NO_SHORT_UPCASE
4776           if (decc_efs_case_preserve)
4777             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4778 #endif
4779           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4780             sts = rms_free_search_context(&dirfab);
4781             Safefree(esa);
4782             Safefree(trndir);
4783             Safefree(vmsdir);
4784             set_errno(EVMSERR);
4785             set_vaxc_errno(dirfab.fab$l_sts);
4786             return NULL;
4787           }
4788           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4789           if (buf) retspec = buf;
4790           else if (ts) Newx(retspec,retlen+16,char);
4791           else retspec = __fileify_retbuf;
4792           cp1 = strstr(esa,"][");
4793           if (!cp1) cp1 = strstr(esa,"]<");
4794           dirlen = cp1 - esa;
4795           memcpy(retspec,esa,dirlen);
4796           if (!strncmp(cp1+2,"000000]",7)) {
4797             retspec[dirlen-1] = '\0';
4798             /* Not full ODS-5, just extra dots in directories for now */
4799             cp1 = retspec + dirlen - 1;
4800             while (cp1 > retspec)
4801             {
4802               if (*cp1 == '[')
4803                 break;
4804               if (*cp1 == '.') {
4805                 if (*(cp1-1) != '^')
4806                   break;
4807               }
4808               cp1--;
4809             }
4810             if (*cp1 == '.') *cp1 = ']';
4811             else {
4812               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4813               memmove(cp1+1,"000000]",7);
4814             }
4815           }
4816           else {
4817             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4818             retspec[retlen] = '\0';
4819             /* Convert last '.' to ']' */
4820             cp1 = retspec+retlen-1;
4821             while (*cp != '[') {
4822               cp1--;
4823               if (*cp1 == '.') {
4824                 /* Do not trip on extra dots in ODS-5 directories */
4825                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4826                 break;
4827               }
4828             }
4829             if (*cp1 == '.') *cp1 = ']';
4830             else {
4831               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4832               memmove(cp1+1,"000000]",7);
4833             }
4834           }
4835         }
4836         else {  /* This is a top-level dir.  Add the MFD to the path. */
4837           if (buf) retspec = buf;
4838           else if (ts) Newx(retspec,retlen+16,char);
4839           else retspec = __fileify_retbuf;
4840           cp1 = esa;
4841           cp2 = retspec;
4842           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
4843           strcpy(cp2,":[000000]");
4844           cp1 += 2;
4845           strcpy(cp2+9,cp1);
4846         }
4847       }
4848       sts = rms_free_search_context(&dirfab);
4849       /* We've set up the string up through the filename.  Add the
4850          type and version, and we're done. */
4851       strcat(retspec,".DIR;1");
4852
4853       /* $PARSE may have upcased filespec, so convert output to lower
4854        * case if input contained any lowercase characters. */
4855       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4856       Safefree(trndir);
4857       Safefree(esa);
4858       Safefree(vmsdir);
4859       return retspec;
4860     }
4861 }  /* end of do_fileify_dirspec() */
4862 /*}}}*/
4863 /* External entry points */
4864 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4865 { return do_fileify_dirspec(dir,buf,0); }
4866 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4867 { return do_fileify_dirspec(dir,buf,1); }
4868
4869 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4870 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4871 {
4872     static char __pathify_retbuf[VMS_MAXRSS];
4873     unsigned long int retlen;
4874     char *retpath, *cp1, *cp2, *trndir;
4875     unsigned short int trnlnm_iter_count;
4876     STRLEN trnlen;
4877     int sts;
4878
4879     if (!dir || !*dir) {
4880       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4881     }
4882
4883     Newx(trndir, VMS_MAXRSS, char);
4884     if (*dir) strcpy(trndir,dir);
4885     else getcwd(trndir,VMS_MAXRSS - 1);
4886
4887     trnlnm_iter_count = 0;
4888     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4889            && my_trnlnm(trndir,trndir,0)) {
4890       trnlnm_iter_count++;
4891       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4892       trnlen = strlen(trndir);
4893
4894       /* Trap simple rooted lnms, and return lnm:[000000] */
4895       if (!strcmp(trndir+trnlen-2,".]")) {
4896         if (buf) retpath = buf;
4897         else if (ts) Newx(retpath,strlen(dir)+10,char);
4898         else retpath = __pathify_retbuf;
4899         strcpy(retpath,dir);
4900         strcat(retpath,":[000000]");
4901         Safefree(trndir);
4902         return retpath;
4903       }
4904     }
4905
4906     /* At this point we do not work with *dir, but the copy in
4907      * *trndir that is modifiable.
4908      */
4909
4910     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4911       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4912                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4913         retlen = 2 + (*(trndir+1) != '\0');
4914       else {
4915         if ( !(cp1 = strrchr(trndir,'/')) &&
4916              !(cp1 = strrchr(trndir,']')) &&
4917              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4918         if ((cp2 = strchr(cp1,'.')) != NULL &&
4919             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4920              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4921               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4922               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4923           int ver; char *cp3;
4924
4925           /* For EFS or ODS-5 look for the last dot */
4926           if (decc_efs_charset) {
4927             cp2 = strrchr(cp1,'.');
4928           }
4929           if (vms_process_case_tolerant) {
4930               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4931                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4932                   !*(cp2+3) || toupper(*(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           else {
4943               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4944                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4945                   !*(cp2+3) || *(cp2+3) != 'R' ||
4946                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4947                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4948                             (ver || *cp3)))))) {
4949                 Safefree(trndir);
4950                 set_errno(ENOTDIR);
4951                 set_vaxc_errno(RMS$_DIR);
4952                 return NULL;
4953               }
4954           }
4955           retlen = cp2 - trndir + 1;
4956         }
4957         else {  /* No file type present.  Treat the filename as a directory. */
4958           retlen = strlen(trndir) + 1;
4959         }
4960       }
4961       if (buf) retpath = buf;
4962       else if (ts) Newx(retpath,retlen+1,char);
4963       else retpath = __pathify_retbuf;
4964       strncpy(retpath, trndir, retlen-1);
4965       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4966         retpath[retlen-1] = '/';      /* with '/', add it. */
4967         retpath[retlen] = '\0';
4968       }
4969       else retpath[retlen-1] = '\0';
4970     }
4971     else {  /* VMS-style directory spec */
4972       char *esa, *cp;
4973       unsigned long int sts, cmplen, haslower;
4974       struct FAB dirfab = cc$rms_fab;
4975       int dirlen;
4976       rms_setup_nam(savnam);
4977       rms_setup_nam(dirnam);
4978
4979       /* If we've got an explicit filename, we can just shuffle the string. */
4980       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4981              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4982         if ((cp2 = strchr(cp1,'.')) != NULL) {
4983           int ver; char *cp3;
4984           if (vms_process_case_tolerant) {
4985               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4986                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4987                   !*(cp2+3) || toupper(*(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           else {
4998               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4999                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5000                   !*(cp2+3) || *(cp2+3) != 'R' ||
5001                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5002                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5003                             (ver || *cp3)))))) {
5004                Safefree(trndir);
5005                set_errno(ENOTDIR);
5006                set_vaxc_errno(RMS$_DIR);
5007                return NULL;
5008              }
5009           }
5010         }
5011         else {  /* No file type, so just draw name into directory part */
5012           for (cp2 = cp1; *cp2; cp2++) ;
5013         }
5014         *cp2 = *cp1;
5015         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5016         *cp1 = '.';
5017         /* We've now got a VMS 'path'; fall through */
5018       }
5019
5020       dirlen = strlen(trndir);
5021       if (trndir[dirlen-1] == ']' ||
5022           trndir[dirlen-1] == '>' ||
5023           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5024         if (buf) retpath = buf;
5025         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5026         else retpath = __pathify_retbuf;
5027         strcpy(retpath,trndir);
5028         Safefree(trndir);
5029         return retpath;
5030       }
5031       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5032       Newx(esa, VMS_MAXRSS, char);
5033       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5034       rms_bind_fab_nam(dirfab, dirnam);
5035       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5036 #ifdef NAM$M_NO_SHORT_UPCASE
5037       if (decc_efs_case_preserve)
5038           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5039 #endif
5040
5041       for (cp = trndir; *cp; cp++)
5042         if (islower(*cp)) { haslower = 1; break; }
5043
5044       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5045         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5046           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5047           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5048         }
5049         if (!sts) {
5050           Safefree(trndir);
5051           Safefree(esa);
5052           set_errno(EVMSERR);
5053           set_vaxc_errno(dirfab.fab$l_sts);
5054           return NULL;
5055         }
5056       }
5057       else {
5058         savnam = dirnam;
5059         /* Does the file really exist? */
5060         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5061           if (dirfab.fab$l_sts != RMS$_FNF) {
5062             int sts1;
5063             sts1 = rms_free_search_context(&dirfab);
5064             Safefree(trndir);
5065             Safefree(esa);
5066             set_errno(EVMSERR);
5067             set_vaxc_errno(dirfab.fab$l_sts);
5068             return NULL;
5069           }
5070           dirnam = savnam; /* No; just work with potential name */
5071         }
5072       }
5073       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5074         /* Yep; check version while we're at it, if it's there. */
5075         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5076         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5077           int sts2;
5078           /* Something other than .DIR[;1].  Bzzt. */
5079           sts2 = rms_free_search_context(&dirfab);
5080           Safefree(trndir);
5081           Safefree(esa);
5082           set_errno(ENOTDIR);
5083           set_vaxc_errno(RMS$_DIR);
5084           return NULL;
5085         }
5086       }
5087       /* OK, the type was fine.  Now pull any file name into the
5088          directory path. */
5089       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5090       else {
5091         cp1 = strrchr(esa,'>');
5092         *(rms_nam_typel(dirnam)) = '>';
5093       }
5094       *cp1 = '.';
5095       *(rms_nam_typel(dirnam) + 1) = '\0';
5096       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5097       if (buf) retpath = buf;
5098       else if (ts) Newx(retpath,retlen,char);
5099       else retpath = __pathify_retbuf;
5100       strcpy(retpath,esa);
5101       Safefree(esa);
5102       sts = rms_free_search_context(&dirfab);
5103       /* $PARSE may have upcased filespec, so convert output to lower
5104        * case if input contained any lowercase characters. */
5105       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5106     }
5107
5108     Safefree(trndir);
5109     return retpath;
5110 }  /* end of do_pathify_dirspec() */
5111 /*}}}*/
5112 /* External entry points */
5113 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5114 { return do_pathify_dirspec(dir,buf,0); }
5115 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5116 { return do_pathify_dirspec(dir,buf,1); }
5117
5118 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5119 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5120 {
5121   static char __tounixspec_retbuf[VMS_MAXRSS];
5122   char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5123   const char *cp2;
5124   int devlen, dirlen, retlen = VMS_MAXRSS;
5125   int expand = 1; /* guarantee room for leading and trailing slashes */
5126   unsigned short int trnlnm_iter_count;
5127   int cmp_rslt;
5128
5129   if (spec == NULL) return NULL;
5130   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5131   if (buf) rslt = buf;
5132   else if (ts) {
5133     retlen = strlen(spec);
5134     cp1 = strchr(spec,'[');
5135     if (!cp1) cp1 = strchr(spec,'<');
5136     if (cp1) {
5137       for (cp1++; *cp1; cp1++) {
5138         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5139         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5140           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5141       }
5142     }
5143     Newx(rslt,retlen+2+2*expand,char);
5144   }
5145   else rslt = __tounixspec_retbuf;
5146
5147   /* New VMS specific format needs translation
5148    * glob passes filenames with trailing '\n' and expects this preserved.
5149    */
5150   if (decc_posix_compliant_pathnames) {
5151     if (strncmp(spec, "\"^UP^", 5) == 0) {
5152       char * uspec;
5153       char *tunix;
5154       int tunix_len;
5155       int nl_flag;
5156
5157       Newx(tunix, VMS_MAXRSS + 1,char);
5158       strcpy(tunix, spec);
5159       tunix_len = strlen(tunix);
5160       nl_flag = 0;
5161       if (tunix[tunix_len - 1] == '\n') {
5162         tunix[tunix_len - 1] = '\"';
5163         tunix[tunix_len] = '\0';
5164         tunix_len--;
5165         nl_flag = 1;
5166       }
5167       uspec = decc$translate_vms(tunix);
5168       Safefree(tunix);
5169       if ((int)uspec > 0) {
5170         strcpy(rslt,uspec);
5171         if (nl_flag) {
5172           strcat(rslt,"\n");
5173         }
5174         else {
5175           /* If we can not translate it, makemaker wants as-is */
5176           strcpy(rslt, spec);
5177         }
5178         return rslt;
5179       }
5180     }
5181   }
5182
5183   cmp_rslt = 0; /* Presume VMS */
5184   cp1 = strchr(spec, '/');
5185   if (cp1 == NULL)
5186     cmp_rslt = 0;
5187
5188     /* Look for EFS ^/ */
5189     if (decc_efs_charset) {
5190       while (cp1 != NULL) {
5191         cp2 = cp1 - 1;
5192         if (*cp2 != '^') {
5193           /* Found illegal VMS, assume UNIX */
5194           cmp_rslt = 1;
5195           break;
5196         }
5197       cp1++;
5198       cp1 = strchr(cp1, '/');
5199     }
5200   }
5201
5202   /* Look for "." and ".." */
5203   if (decc_filename_unix_report) {
5204     if (spec[0] == '.') {
5205       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5206         cmp_rslt = 1;
5207       }
5208       else {
5209         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5210           cmp_rslt = 1;
5211         }
5212       }
5213     }
5214   }
5215   /* This is already UNIX or at least nothing VMS understands */
5216   if (cmp_rslt) {
5217     strcpy(rslt,spec);
5218     return rslt;
5219   }
5220
5221   cp1 = rslt;
5222   cp2 = spec;
5223   dirend = strrchr(spec,']');
5224   if (dirend == NULL) dirend = strrchr(spec,'>');
5225   if (dirend == NULL) dirend = strchr(spec,':');
5226   if (dirend == NULL) {
5227     strcpy(rslt,spec);
5228     return rslt;
5229   }
5230
5231   /* Special case 1 - sys$posix_root = / */
5232 #if __CRTL_VER >= 70000000
5233   if (!decc_disable_posix_root) {
5234     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5235       *cp1 = '/';
5236       cp1++;
5237       cp2 = cp2 + 15;
5238       }
5239   }
5240 #endif
5241
5242   /* Special case 2 - Convert NLA0: to /dev/null */
5243 #if __CRTL_VER < 70000000
5244   cmp_rslt = strncmp(spec,"NLA0:", 5);
5245   if (cmp_rslt != 0)
5246      cmp_rslt = strncmp(spec,"nla0:", 5);
5247 #else
5248   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5249 #endif
5250   if (cmp_rslt == 0) {
5251     strcpy(rslt, "/dev/null");
5252     cp1 = cp1 + 9;
5253     cp2 = cp2 + 5;
5254     if (spec[6] != '\0') {
5255       cp1[9] == '/';
5256       cp1++;
5257       cp2++;
5258     }
5259   }
5260
5261    /* Also handle special case "SYS$SCRATCH:" */
5262 #if __CRTL_VER < 70000000
5263   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5264   if (cmp_rslt != 0)
5265      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5266 #else
5267   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5268 #endif
5269   if (cmp_rslt == 0) {
5270   int islnm;
5271
5272     islnm = my_trnlnm(tmp, "TMP", 0);
5273     if (!islnm) {
5274       strcpy(rslt, "/tmp");
5275       cp1 = cp1 + 4;
5276       cp2 = cp2 + 12;
5277       if (spec[12] != '\0') {
5278         cp1[4] == '/';
5279         cp1++;
5280         cp2++;
5281       }
5282     }
5283   }
5284
5285   if (*cp2 != '[' && *cp2 != '<') {
5286     *(cp1++) = '/';
5287   }
5288   else {  /* the VMS spec begins with directories */
5289     cp2++;
5290     if (*cp2 == ']' || *cp2 == '>') {
5291       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5292       return rslt;
5293     }
5294     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5295       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5296         if (ts) Safefree(rslt);
5297         return NULL;
5298       }
5299       trnlnm_iter_count = 0;
5300       do {
5301         cp3 = tmp;
5302         while (*cp3 != ':' && *cp3) cp3++;
5303         *(cp3++) = '\0';
5304         if (strchr(cp3,']') != NULL) break;
5305         trnlnm_iter_count++;
5306         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5307       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5308       if (ts && !buf &&
5309           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5310         retlen = devlen + dirlen;
5311         Renew(rslt,retlen+1+2*expand,char);
5312         cp1 = rslt;
5313       }
5314       cp3 = tmp;
5315       *(cp1++) = '/';
5316       while (*cp3) {
5317         *(cp1++) = *(cp3++);
5318         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5319       }
5320       *(cp1++) = '/';
5321     }
5322     if ((*cp2 == '^')) {
5323         /* EFS file escape, pass the next character as is */
5324         /* Fix me: HEX encoding for UNICODE not implemented */
5325         cp2++;
5326     }
5327     else if ( *cp2 == '.') {
5328       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5329         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5330         cp2 += 3;
5331       }
5332       else cp2++;
5333     }
5334   }
5335   for (; cp2 <= dirend; cp2++) {
5336     if ((*cp2 == '^')) {
5337         /* EFS file escape, pass the next character as is */
5338         /* Fix me: HEX encoding for UNICODE not implemented */
5339         cp2++;
5340         *(cp1++) = *cp2;
5341     }
5342     if (*cp2 == ':') {
5343       *(cp1++) = '/';
5344       if (*(cp2+1) == '[') cp2++;
5345     }
5346     else if (*cp2 == ']' || *cp2 == '>') {
5347       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5348     }
5349     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5350       *(cp1++) = '/';
5351       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5352         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5353                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5354         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5355             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5356       }
5357       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5358         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5359         cp2 += 2;
5360       }
5361     }
5362     else if (*cp2 == '-') {
5363       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5364         while (*cp2 == '-') {
5365           cp2++;
5366           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5367         }
5368         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5369           if (ts) Safefree(rslt);                        /* filespecs like */
5370           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5371           return NULL;
5372         }
5373       }
5374       else *(cp1++) = *cp2;
5375     }
5376     else *(cp1++) = *cp2;
5377   }
5378   while (*cp2) *(cp1++) = *(cp2++);
5379   *cp1 = '\0';
5380
5381   /* This still leaves /000000/ when working with a
5382    * VMS device root or concealed root.
5383    */
5384   {
5385   int ulen;
5386   char * zeros;
5387
5388       ulen = strlen(rslt);
5389
5390       /* Get rid of "000000/ in rooted filespecs */
5391       if (ulen > 7) {
5392         zeros = strstr(rslt, "/000000/");
5393         if (zeros != NULL) {
5394           int mlen;
5395           mlen = ulen - (zeros - rslt) - 7;
5396           memmove(zeros, &zeros[7], mlen);
5397           ulen = ulen - 7;
5398           rslt[ulen] = '\0';
5399         }
5400       }
5401   }
5402
5403   return rslt;
5404
5405 }  /* end of do_tounixspec() */
5406 /*}}}*/
5407 /* External entry points */
5408 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5409 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5410
5411 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5412
5413 static int posix_to_vmsspec
5414   (char *vmspath, int vmspath_len, const char *unixpath) {
5415 int sts;
5416 struct FAB myfab = cc$rms_fab;
5417 struct NAML mynam = cc$rms_naml;
5418 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5419  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5420 char *esa;
5421 char *vms_delim;
5422 int dir_flag;
5423 int unixlen;
5424
5425   /* If not a posix spec already, convert it */
5426   dir_flag = 0;
5427   unixlen = strlen(unixpath);
5428   if (unixlen == 0) {
5429     vmspath[0] = '\0';
5430     return SS$_NORMAL;
5431   }
5432   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5433     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5434   }
5435   else {
5436     /* This is already a VMS specification, no conversion */
5437     unixlen--;
5438     strncpy(vmspath,unixpath, vmspath_len);
5439   }
5440   vmspath[vmspath_len] = 0;
5441   if (unixpath[unixlen - 1] == '/')
5442   dir_flag = 1;
5443   Newx(esa, VMS_MAXRSS, char);
5444   myfab.fab$l_fna = vmspath;
5445   myfab.fab$b_fns = strlen(vmspath);
5446   myfab.fab$l_naml = &mynam;
5447   mynam.naml$l_esa = NULL;
5448   mynam.naml$b_ess = 0;
5449   mynam.naml$l_long_expand = esa;
5450   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5451   mynam.naml$l_rsa = NULL;
5452   mynam.naml$b_rss = 0;
5453   if (decc_efs_case_preserve)
5454     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5455   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5456
5457   /* Set up the remaining naml fields */
5458   sts = sys$parse(&myfab);
5459
5460   /* It failed! Try again as a UNIX filespec */
5461   if (!(sts & 1)) {
5462     Safefree(esa);
5463     return sts;
5464   }
5465
5466    /* get the Device ID and the FID */
5467    sts = sys$search(&myfab);
5468    /* on any failure, returned the POSIX ^UP^ filespec */
5469    if (!(sts & 1)) {
5470       Safefree(esa);
5471       return sts;
5472    }
5473    specdsc.dsc$a_pointer = vmspath;
5474    specdsc.dsc$w_length = vmspath_len;
5475
5476    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5477    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5478    sts = lib$fid_to_name
5479       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5480
5481   /* on any failure, returned the POSIX ^UP^ filespec */
5482   if (!(sts & 1)) {
5483      /* This can happen if user does not have permission to read directories */
5484      if (strncmp(unixpath,"\"^UP^",5) != 0)
5485        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5486      else
5487        strcpy(vmspath, unixpath);
5488   }
5489   else {
5490     vmspath[specdsc.dsc$w_length] = 0;
5491
5492     /* Are we expecting a directory? */
5493     if (dir_flag != 0) {
5494     int i;
5495     char *eptr;
5496
5497       eptr = NULL;
5498
5499       i = specdsc.dsc$w_length - 1;
5500       while (i > 0) {
5501       int zercnt;
5502         zercnt = 0;
5503         /* Version must be '1' */
5504         if (vmspath[i--] != '1')
5505           break;
5506         /* Version delimiter is one of ".;" */
5507         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5508           break;
5509         i--;
5510         if (vmspath[i--] != 'R')
5511           break;
5512         if (vmspath[i--] != 'I')
5513           break;
5514         if (vmspath[i--] != 'D')
5515           break;
5516         if (vmspath[i--] != '.')
5517           break;
5518         eptr = &vmspath[i+1];
5519         while (i > 0) {
5520           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5521             if (vmspath[i-1] != '^') {
5522               if (zercnt != 6) {
5523                 *eptr = vmspath[i];
5524                 eptr[1] = '\0';
5525                 vmspath[i] = '.';
5526                 break;
5527               }
5528               else {
5529                 /* Get rid of 6 imaginary zero directory filename */
5530                 vmspath[i+1] = '\0';
5531               }
5532             }
5533           }
5534           if (vmspath[i] == '0')
5535             zercnt++;
5536           else
5537             zercnt = 10;
5538           i--;
5539         }
5540         break;
5541       }
5542     }
5543   }
5544   Safefree(esa);
5545   return sts;
5546 }
5547
5548 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5549 static int posix_to_vmsspec_hardway
5550   (char *vmspath, int vmspath_len, const char *unixpath) {
5551
5552 char *esa;
5553 const char *unixptr;
5554 char *vmsptr;
5555 const char *lastslash;
5556 const char *lastdot;
5557 int unixlen;
5558 int vmslen;
5559 int dir_start;
5560 int dir_dot;
5561 int quoted;
5562
5563
5564   unixptr = unixpath;
5565   dir_dot = 0;
5566
5567   /* Ignore leading "/" characters */
5568   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5569     unixptr++;
5570   }
5571   unixlen = strlen(unixptr);
5572
5573   /* Do nothing with blank paths */
5574   if (unixlen == 0) {
5575     vmspath[0] = '\0';
5576     return SS$_NORMAL;
5577   }
5578
5579   lastslash = strrchr(unixptr,'/');
5580   lastdot = strrchr(unixptr,'.');
5581
5582
5583   /* last dot is last dot or past end of string */
5584   if (lastdot == NULL)
5585     lastdot = unixptr + unixlen;
5586
5587   /* if no directories, set last slash to beginning of string */
5588   if (lastslash == NULL) {
5589     lastslash = unixptr;
5590   }
5591   else {
5592     /* Watch out for trailing "." after last slash, still a directory */
5593     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5594       lastslash = unixptr + unixlen;
5595     }
5596
5597     /* Watch out for traiing ".." after last slash, still a directory */
5598     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5599       lastslash = unixptr + unixlen;
5600     }
5601
5602     /* dots in directories are aways escaped */
5603     if (lastdot < lastslash)
5604       lastdot = unixptr + unixlen;
5605   }
5606
5607   /* if (unixptr < lastslash) then we are in a directory */
5608
5609   dir_start = 0;
5610   quoted = 0;
5611
5612   vmsptr = vmspath;
5613   vmslen = 0;
5614
5615   /* This could have a "^UP^ on the front */
5616   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5617     quoted = 1;
5618     unixptr+= 5;
5619   }
5620
5621   /* Start with the UNIX path */
5622   if (*unixptr != '/') {
5623     /* relative paths */
5624     if (lastslash > unixptr) {
5625     int dotdir_seen;
5626
5627       /* skip leading ./ */
5628       dotdir_seen = 0;
5629       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5630         dotdir_seen = 1;
5631         unixptr++;
5632         unixptr++;
5633       }
5634
5635       /* Are we still in a directory? */
5636       if (unixptr <= lastslash) {
5637         *vmsptr++ = '[';
5638         vmslen = 1;
5639         dir_start = 1;
5640
5641         /* if not backing up, then it is relative forward. */
5642         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5643               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5644           *vmsptr++ = '.';
5645           vmslen++;
5646           dir_dot = 1;
5647         }
5648        }
5649        else {
5650          if (dotdir_seen) {
5651            /* Perl wants an empty directory here to tell the difference
5652             * between a DCL commmand and a filename
5653             */
5654           *vmsptr++ = '[';
5655           *vmsptr++ = ']';
5656           vmslen = 2;
5657         }
5658       }
5659     }
5660     else {
5661       /* Handle two special files . and .. */
5662       if (unixptr[0] == '.') {
5663         if (unixptr[1] == '\0') {
5664           *vmsptr++ = '[';
5665           *vmsptr++ = ']';
5666           vmslen += 2;
5667           *vmsptr++ = '\0';
5668           return SS$_NORMAL;
5669         }
5670         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5671           *vmsptr++ = '[';
5672           *vmsptr++ = '-';
5673           *vmsptr++ = ']';
5674           vmslen += 3;
5675           *vmsptr++ = '\0';
5676           return SS$_NORMAL;
5677         }
5678       }
5679     }
5680   }
5681   else {        /* Absolute PATH handling */
5682   int sts;
5683   char * nextslash;
5684   int seg_len;
5685     /* Need to find out where root is */
5686
5687     /* In theory, this procedure should never get an absolute POSIX pathname
5688      * that can not be found on the POSIX root.
5689      * In practice, that can not be relied on, and things will show up
5690      * here that are a VMS device name or concealed logical name instead.
5691      * So to make things work, this procedure must be tolerant.
5692      */
5693     Newx(esa, vmspath_len, char);
5694
5695     sts = SS$_NORMAL;
5696     nextslash = strchr(&unixptr[1],'/');
5697     seg_len = 0;
5698     if (nextslash != NULL) {
5699       seg_len = nextslash - &unixptr[1];
5700       strncpy(vmspath, unixptr, seg_len + 1);
5701       vmspath[seg_len+1] = 0;
5702       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5703     }
5704
5705     if (sts & 1) {
5706       /* This is verified to be a real path */
5707
5708       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5709       strcpy(vmspath, esa);
5710       vmslen = strlen(vmspath);
5711       vmsptr = vmspath + vmslen;
5712       unixptr++;
5713       if (unixptr < lastslash) {
5714       char * rptr;
5715         vmsptr--;
5716         *vmsptr++ = '.';
5717         dir_start = 1;
5718         dir_dot = 1;
5719         if (vmslen > 7) {
5720         int cmp;
5721           rptr = vmsptr - 7;
5722           cmp = strcmp(rptr,"000000.");
5723           if (cmp == 0) {
5724             vmslen -= 7;
5725             vmsptr -= 7;
5726             vmsptr[1] = '\0';
5727           } /* removing 6 zeros */
5728         } /* vmslen < 7, no 6 zeros possible */
5729       } /* Not in a directory */
5730     } /* end of verified real path handling */
5731     else {
5732     int add_6zero;
5733     int islnm;
5734
5735       /* Ok, we have a device or a concealed root that is not in POSIX
5736        * or we have garbage.  Make the best of it.
5737        */
5738
5739       /* Posix to VMS destroyed this, so copy it again */
5740       strncpy(vmspath, &unixptr[1], seg_len);
5741       vmspath[seg_len] = 0;
5742       vmslen = seg_len;
5743       vmsptr = &vmsptr[vmslen];
5744       islnm = 0;
5745
5746       /* Now do we need to add the fake 6 zero directory to it? */
5747       add_6zero = 1;
5748       if ((*lastslash == '/') && (nextslash < lastslash)) {
5749         /* No there is another directory */
5750         add_6zero = 0;
5751       }
5752       else {
5753       int trnend;
5754
5755         /* now we have foo:bar or foo:[000000]bar to decide from */
5756         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5757         trnend = islnm ? islnm - 1 : 0;
5758
5759         /* if this was a logical name, ']' or '>' must be present */
5760         /* if not a logical name, then assume a device and hope. */
5761         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5762
5763         /* if log name and trailing '.' then rooted - treat as device */
5764         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5765
5766         /* Fix me, if not a logical name, a device lookup should be
5767          * done to see if the device is file structured.  If the device
5768          * is not file structured, the 6 zeros should not be put on.
5769          *
5770          * As it is, perl is occasionally looking for dev:[000000]tty.
5771          * which looks a little strange.
5772          */
5773
5774         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5775           /* No real directory present */
5776           add_6zero = 1;
5777         }
5778       }
5779
5780       /* Put the device delimiter on */
5781       *vmsptr++ = ':';
5782       vmslen++;
5783       unixptr = nextslash;
5784       unixptr++;
5785
5786       /* Start directory if needed */
5787       if (!islnm || add_6zero) {
5788         *vmsptr++ = '[';
5789         vmslen++;
5790         dir_start = 1;
5791       }
5792
5793       /* add fake 000000] if needed */
5794       if (add_6zero) {
5795         *vmsptr++ = '0';
5796         *vmsptr++ = '0';
5797         *vmsptr++ = '0';
5798         *vmsptr++ = '0';
5799         *vmsptr++ = '0';
5800         *vmsptr++ = '0';
5801         *vmsptr++ = ']';
5802         vmslen += 7;
5803         dir_start = 0;
5804       }
5805
5806     } /* non-POSIX translation */
5807     Safefree(esa);
5808   } /* End of relative/absolute path handling */
5809
5810   while ((*unixptr) && (vmslen < vmspath_len)){
5811   int dash_flag;
5812
5813     dash_flag = 0;
5814
5815     if (dir_start != 0) {
5816
5817       /* First characters in a directory are handled special */
5818       while ((*unixptr == '/') ||
5819              ((*unixptr == '.') &&
5820               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5821       int loop_flag;
5822
5823         loop_flag = 0;
5824
5825         /* Skip redundant / in specification */
5826         while ((*unixptr == '/') && (dir_start != 0)) {
5827           loop_flag = 1;
5828           unixptr++;
5829           if (unixptr == lastslash)
5830             break;
5831         }
5832         if (unixptr == lastslash)
5833           break;
5834
5835         /* Skip redundant ./ characters */
5836         while ((*unixptr == '.') &&
5837                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5838           loop_flag = 1;
5839           unixptr++;
5840           if (unixptr == lastslash)
5841             break;
5842           if (*unixptr == '/')
5843             unixptr++;
5844         }
5845         if (unixptr == lastslash)
5846           break;
5847
5848         /* Skip redundant ../ characters */
5849         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5850              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5851           /* Set the backing up flag */
5852           loop_flag = 1;
5853           dir_dot = 0;
5854           dash_flag = 1;
5855           *vmsptr++ = '-';
5856           vmslen++;
5857           unixptr++; /* first . */
5858           unixptr++; /* second . */
5859           if (unixptr == lastslash)
5860             break;
5861           if (*unixptr == '/') /* The slash */
5862             unixptr++;
5863         }
5864         if (unixptr == lastslash)
5865           break;
5866
5867         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5868         /* Not needed when VMS is pretending to be UNIX. */
5869
5870         /* Is this loop stuck because of too many dots? */
5871         if (loop_flag == 0) {
5872           /* Exit the loop and pass the rest through */
5873           break;
5874         }
5875       }
5876
5877       /* Are we done with directories yet? */
5878       if (unixptr >= lastslash) {
5879
5880         /* Watch out for trailing dots */
5881         if (dir_dot != 0) {
5882             vmslen --;
5883             vmsptr--;
5884         }
5885         *vmsptr++ = ']';
5886         vmslen++;
5887         dash_flag = 0;
5888         dir_start = 0;
5889         if (*unixptr == '/')
5890           unixptr++;
5891       }
5892       else {
5893         /* Have we stopped backing up? */
5894         if (dash_flag) {
5895           *vmsptr++ = '.';
5896           vmslen++;
5897           dash_flag = 0;
5898           /* dir_start continues to be = 1 */
5899         }
5900         if (*unixptr == '-') {
5901           *vmsptr++ = '^';
5902           *vmsptr++ = *unixptr++;
5903           vmslen += 2;
5904           dir_start = 0;
5905
5906           /* Now are we done with directories yet? */
5907           if (unixptr >= lastslash) {
5908
5909             /* Watch out for trailing dots */
5910             if (dir_dot != 0) {
5911               vmslen --;
5912               vmsptr--;
5913             }
5914
5915             *vmsptr++ = ']';
5916             vmslen++;
5917             dash_flag = 0;
5918             dir_start = 0;
5919           }
5920         }
5921       }
5922     }
5923
5924     /* All done? */
5925     if (*unixptr == '\0')
5926       break;
5927
5928     /* Normal characters - More EFS work probably needed */
5929     dir_start = 0;
5930     dir_dot = 0;
5931
5932     switch(*unixptr) {
5933     case '/':
5934         /* remove multiple / */
5935         while (unixptr[1] == '/') {
5936            unixptr++;
5937         }
5938         if (unixptr == lastslash) {
5939           /* Watch out for trailing dots */
5940           if (dir_dot != 0) {
5941             vmslen --;
5942             vmsptr--;
5943           }
5944           *vmsptr++ = ']';
5945         }
5946         else {
5947           dir_start = 1;
5948           *vmsptr++ = '.';
5949           dir_dot = 1;
5950
5951           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5952           /* Not needed when VMS is pretending to be UNIX. */
5953
5954         }
5955         dash_flag = 0;
5956         if (*unixptr != '\0')
5957           unixptr++;
5958         vmslen++;
5959         break;
5960     case '?':
5961         *vmsptr++ = '%';
5962         vmslen++;
5963         unixptr++;
5964         break;
5965     case ' ':
5966         *vmsptr++ = '^';
5967         *vmsptr++ = '_';
5968         vmslen += 2;
5969         unixptr++;
5970         break;
5971     case '.':
5972         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5973           *vmsptr++ = '^';
5974           *vmsptr++ = '.';
5975           vmslen += 2;
5976           unixptr++;
5977
5978           /* trailing dot ==> '^..' on VMS */
5979           if (*unixptr == '\0') {
5980             *vmsptr++ = '.';
5981             vmslen++;
5982           }
5983           *vmsptr++ = *unixptr++;
5984           vmslen ++;
5985         }
5986         if (quoted && (unixptr[1] == '\0')) {
5987           unixptr++;
5988           break;
5989         }
5990         *vmsptr++ = '^';
5991         *vmsptr++ = *unixptr++;
5992         vmslen += 2;
5993         break;
5994     case '~':
5995     case ';':
5996     case '\\':
5997         *vmsptr++ = '^';
5998         *vmsptr++ = *unixptr++;
5999         vmslen += 2;
6000         break;
6001     default:
6002         if (*unixptr != '\0') {
6003           *vmsptr++ = *unixptr++;
6004           vmslen++;
6005         }
6006         break;
6007     }
6008   }
6009
6010   /* Make sure directory is closed */
6011   if (unixptr == lastslash) {
6012     char *vmsptr2;
6013     vmsptr2 = vmsptr - 1;
6014
6015     if (*vmsptr2 != ']') {
6016       *vmsptr2--;
6017
6018       /* directories do not end in a dot bracket */
6019       if (*vmsptr2 == '.') {
6020         vmsptr2--;
6021
6022         /* ^. is allowed */
6023         if (*vmsptr2 != '^') {
6024           vmsptr--; /* back up over the dot */
6025         }
6026       }
6027       *vmsptr++ = ']';
6028     }
6029   }
6030   else {
6031     char *vmsptr2;
6032     /* Add a trailing dot if a file with no extension */
6033     vmsptr2 = vmsptr - 1;
6034     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6035         (*lastdot != '.')) {
6036         *vmsptr++ = '.';
6037         vmslen++;
6038     }
6039   }
6040
6041   *vmsptr = '\0';
6042   return SS$_NORMAL;
6043 }
6044 #endif
6045
6046 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6047 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6048   static char __tovmsspec_retbuf[VMS_MAXRSS];
6049   char *rslt, *dirend;
6050   char *lastdot;
6051   char *vms_delim;
6052   register char *cp1;
6053   const char *cp2;
6054   unsigned long int infront = 0, hasdir = 1;
6055   int rslt_len;
6056   int no_type_seen;
6057
6058   if (path == NULL) return NULL;
6059   rslt_len = VMS_MAXRSS;
6060   if (buf) rslt = buf;
6061   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6062   else rslt = __tovmsspec_retbuf;
6063   if (strpbrk(path,"]:>") ||
6064       (dirend = strrchr(path,'/')) == NULL) {
6065     if (path[0] == '.') {
6066       if (path[1] == '\0') strcpy(rslt,"[]");
6067       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6068       else strcpy(rslt,path); /* probably garbage */
6069     }
6070     else strcpy(rslt,path);
6071     return rslt;
6072   }
6073
6074    /* Posix specifications are now a native VMS format */
6075   /*--------------------------------------------------*/
6076 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6077   if (decc_posix_compliant_pathnames) {
6078     if (strncmp(path,"\"^UP^",5) == 0) {
6079       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6080       return rslt;
6081     }
6082   }
6083 #endif
6084
6085   vms_delim = strpbrk(path,"]:>");
6086
6087   if ((vms_delim != NULL) ||
6088       ((dirend = strrchr(path,'/')) == NULL)) {
6089
6090     /* VMS special characters found! */
6091
6092     if (path[0] == '.') {
6093       if (path[1] == '\0') strcpy(rslt,"[]");
6094       else if (path[1] == '.' && path[2] == '\0')
6095         strcpy(rslt,"[-]");
6096
6097       /* Dot preceeding a device or directory ? */
6098       else {
6099         /* If not in POSIX mode, pass it through and hope it works */
6100 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6101         if (!decc_posix_compliant_pathnames)
6102           strcpy(rslt,path); /* probably garbage */
6103         else
6104           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6105 #else
6106         strcpy(rslt,path); /* probably garbage */
6107 #endif
6108       }
6109     }
6110     else {
6111
6112        /* If no VMS characters and in POSIX mode, convert it!
6113         * This is the easiest way to get directory specifications
6114         * handled correctly in POSIX mode
6115         */
6116 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6117       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6118         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6119       else {
6120         /* No unix path separators - presume VMS already */
6121         strcpy(rslt,path);
6122       }
6123 #else
6124       strcpy(rslt,path); /* probably garbage */
6125 #endif
6126     }
6127     return rslt;
6128   }
6129
6130 /* If POSIX mode active, handle the conversion */
6131 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6132   if (decc_posix_compliant_pathnames) {
6133     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6134     return rslt;
6135   }
6136 #endif
6137
6138   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6139     if (!*(dirend+2)) dirend +=2;
6140     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6141     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6142   }
6143
6144   cp1 = rslt;
6145   cp2 = path;
6146   lastdot = strrchr(cp2,'.');
6147   if (*cp2 == '/') {
6148     char *trndev;
6149     int islnm, rooted;
6150     STRLEN trnend;
6151
6152     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6153     if (!*(cp2+1)) {
6154       if (decc_disable_posix_root) {
6155         strcpy(rslt,"sys$disk:[000000]");
6156       }
6157       else {
6158         strcpy(rslt,"sys$posix_root:[000000]");
6159       }
6160       return rslt;
6161     }
6162     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6163     *cp1 = '\0';
6164     Newx(trndev, VMS_MAXRSS, char);
6165     islnm =  my_trnlnm(rslt,trndev,0);
6166
6167      /* DECC special handling */
6168     if (!islnm) {
6169       if (strcmp(rslt,"bin") == 0) {
6170         strcpy(rslt,"sys$system");
6171         cp1 = rslt + 10;
6172         *cp1 = 0;
6173         islnm =  my_trnlnm(rslt,trndev,0);
6174       }
6175       else if (strcmp(rslt,"tmp") == 0) {
6176         strcpy(rslt,"sys$scratch");
6177         cp1 = rslt + 11;
6178         *cp1 = 0;
6179         islnm =  my_trnlnm(rslt,trndev,0);
6180       }
6181       else if (!decc_disable_posix_root) {
6182         strcpy(rslt, "sys$posix_root");
6183         cp1 = rslt + 13;
6184         *cp1 = 0;
6185         cp2 = path;
6186         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6187         islnm =  my_trnlnm(rslt,trndev,0);
6188       }
6189       else if (strcmp(rslt,"dev") == 0) {
6190         if (strncmp(cp2,"/null", 5) == 0) {
6191           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6192             strcpy(rslt,"NLA0");
6193             cp1 = rslt + 4;
6194             *cp1 = 0;
6195             cp2 = cp2 + 5;
6196             islnm =  my_trnlnm(rslt,trndev,0);
6197           }
6198         }
6199       }
6200     }
6201
6202     trnend = islnm ? strlen(trndev) - 1 : 0;
6203     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6204     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6205     /* If the first element of the path is a logical name, determine
6206      * whether it has to be translated so we can add more directories. */
6207     if (!islnm || rooted) {
6208       *(cp1++) = ':';
6209       *(cp1++) = '[';
6210       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6211       else cp2++;
6212     }
6213     else {
6214       if (cp2 != dirend) {
6215         strcpy(rslt,trndev);
6216         cp1 = rslt + trnend;
6217         if (*cp2 != 0) {
6218           *(cp1++) = '.';
6219           cp2++;
6220         }
6221       }
6222       else {
6223         if (decc_disable_posix_root) {
6224           *(cp1++) = ':';
6225           hasdir = 0;
6226         }
6227       }
6228     }
6229     Safefree(trndev);
6230   }
6231   else {
6232     *(cp1++) = '[';
6233     if (*cp2 == '.') {
6234       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6235         cp2 += 2;         /* skip over "./" - it's redundant */
6236         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6237       }
6238       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6239         *(cp1++) = '-';                                 /* "../" --> "-" */
6240         cp2 += 3;
6241       }
6242       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6243                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6244         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6245         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6246         cp2 += 4;
6247       }
6248       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6249         /* Escape the extra dots in EFS file specifications */
6250         *(cp1++) = '^';
6251       }
6252       if (cp2 > dirend) cp2 = dirend;
6253     }
6254     else *(cp1++) = '.';
6255   }
6256   for (; cp2 < dirend; cp2++) {
6257     if (*cp2 == '/') {
6258       if (*(cp2-1) == '/') continue;
6259       if (*(cp1-1) != '.') *(cp1++) = '.';
6260       infront = 0;
6261     }
6262     else if (!infront && *cp2 == '.') {
6263       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6264       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6265       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6266         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6267         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6268         else {  /* back up over previous directory name */
6269           cp1--;
6270           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6271           if (*(cp1-1) == '[') {
6272             memcpy(cp1,"000000.",7);
6273             cp1 += 7;
6274           }
6275         }
6276         cp2 += 2;
6277         if (cp2 == dirend) break;
6278       }
6279       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6280                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6281         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6282         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6283         if (!*(cp2+3)) {
6284           *(cp1++) = '.';  /* Simulate trailing '/' */
6285           cp2 += 2;  /* for loop will incr this to == dirend */
6286         }
6287         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6288       }
6289       else {
6290         if (decc_efs_charset == 0)
6291           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6292         else {
6293           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6294           *(cp1++) = '.';
6295         }
6296       }
6297     }
6298     else {
6299       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6300       if (*cp2 == '.') {
6301         if (decc_efs_charset == 0)
6302           *(cp1++) = '_';
6303         else {
6304           *(cp1++) = '^';
6305           *(cp1++) = '.';
6306         }
6307       }
6308       else                  *(cp1++) =  *cp2;
6309       infront = 1;
6310     }
6311   }
6312   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6313   if (hasdir) *(cp1++) = ']';
6314   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6315   /* fixme for ODS5 */
6316   no_type_seen = 0;
6317   if (cp2 > lastdot)
6318     no_type_seen = 1;
6319   while (*cp2) {
6320     switch(*cp2) {
6321     case '?':
6322         *(cp1++) = '%';
6323         cp2++;
6324     case ' ':
6325         *(cp1)++ = '^';
6326         *(cp1)++ = '_';
6327         cp2++;
6328         break;
6329     case '.':
6330         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6331             decc_readdir_dropdotnotype) {
6332           *(cp1)++ = '^';
6333           *(cp1)++ = '.';
6334           cp2++;
6335
6336           /* trailing dot ==> '^..' on VMS */
6337           if (*cp2 == '\0') {
6338             *(cp1++) = '.';
6339             no_type_seen = 0;
6340           }
6341         }
6342         else {
6343           *(cp1++) = *(cp2++);
6344           no_type_seen = 0;
6345         }
6346         break;
6347     case '\"':
6348     case '~':
6349     case '`':
6350     case '!':
6351     case '#':
6352     case '%':
6353     case '^':
6354     case '&':
6355     case '(':
6356     case ')':
6357     case '=':
6358     case '+':
6359     case '\'':
6360     case '@':
6361     case '[':
6362     case ']':
6363     case '{':
6364     case '}':
6365     case ':':
6366     case '\\':
6367     case '|':
6368     case '<':
6369     case '>':
6370         *(cp1++) = '^';
6371         *(cp1++) = *(cp2++);
6372         break;
6373     case ';':
6374         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6375          * which is wrong.  UNIX notation should be ".dir. unless
6376          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6377          * changing this behavior could break more things at this time.
6378          * efs character set effectively does not allow "." to be a version
6379          * delimiter as a further complication about changing this.
6380          */
6381         if (decc_filename_unix_report != 0) {
6382           *(cp1++) = '^';
6383         }
6384         *(cp1++) = *(cp2++);
6385         break;
6386     default:
6387         *(cp1++) = *(cp2++);
6388     }
6389   }
6390   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6391   char *lcp1;
6392     lcp1 = cp1;
6393     lcp1--;
6394      /* Fix me for "^]", but that requires making sure that you do
6395       * not back up past the start of the filename
6396       */
6397     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6398       *cp1++ = '.';
6399   }
6400   *cp1 = '\0';
6401
6402   return rslt;
6403
6404 }  /* end of do_tovmsspec() */
6405 /*}}}*/
6406 /* External entry points */
6407 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6408 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6409
6410 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6411 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6412   static char __tovmspath_retbuf[VMS_MAXRSS];
6413   int vmslen;
6414   char *pathified, *vmsified, *cp;
6415
6416   if (path == NULL) return NULL;
6417   Newx(pathified, VMS_MAXRSS, char);
6418   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6419     Safefree(pathified);
6420     return NULL;
6421   }
6422   Newx(vmsified, VMS_MAXRSS, char);
6423   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6424     Safefree(pathified);
6425     Safefree(vmsified);
6426     return NULL;
6427   }
6428   Safefree(pathified);
6429   if (buf) {
6430     Safefree(vmsified);
6431     return buf;
6432   }
6433   else if (ts) {
6434     vmslen = strlen(vmsified);
6435     Newx(cp,vmslen+1,char);
6436     memcpy(cp,vmsified,vmslen);
6437     cp[vmslen] = '\0';
6438     Safefree(vmsified);
6439     return cp;
6440   }
6441   else {
6442     strcpy(__tovmspath_retbuf,vmsified);
6443     Safefree(vmsified);
6444     return __tovmspath_retbuf;
6445   }
6446
6447 }  /* end of do_tovmspath() */
6448 /*}}}*/
6449 /* External entry points */
6450 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6451 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6452
6453
6454 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6455 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6456   static char __tounixpath_retbuf[VMS_MAXRSS];
6457   int unixlen;
6458   char *pathified, *unixified, *cp;
6459
6460   if (path == NULL) return NULL;
6461   Newx(pathified, VMS_MAXRSS, char);
6462   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6463     Safefree(pathified);
6464     return NULL;
6465   }
6466   Newx(unixified, VMS_MAXRSS, char);
6467   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6468     Safefree(pathified);
6469     Safefree(unixified);
6470     return NULL;
6471   }
6472   Safefree(pathified);
6473   if (buf) {
6474     Safefree(unixified);
6475     return buf;
6476   }
6477   else if (ts) {
6478     unixlen = strlen(unixified);
6479     Newx(cp,unixlen+1,char);
6480     memcpy(cp,unixified,unixlen);
6481     cp[unixlen] = '\0';
6482     Safefree(unixified);
6483     return cp;
6484   }
6485   else {
6486     strcpy(__tounixpath_retbuf,unixified);
6487     Safefree(unixified);
6488     return __tounixpath_retbuf;
6489   }
6490
6491 }  /* end of do_tounixpath() */
6492 /*}}}*/
6493 /* External entry points */
6494 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6495 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6496
6497 /*
6498  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6499  *
6500  *****************************************************************************
6501  *                                                                           *
6502  *  Copyright (C) 1989-1994 by                                               *
6503  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6504  *                                                                           *
6505  *  Permission is hereby  granted for the reproduction of this software,     *
6506  *  on condition that this copyright notice is included in the reproduction, *
6507  *  and that such reproduction is not for purposes of profit or material     *
6508  *  gain.                                                                    *
6509  *                                                                           *
6510  *  27-Aug-1994 Modified for inclusion in perl5                              *
6511  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6512  *****************************************************************************
6513  */
6514
6515 /*
6516  * getredirection() is intended to aid in porting C programs
6517  * to VMS (Vax-11 C).  The native VMS environment does not support
6518  * '>' and '<' I/O redirection, or command line wild card expansion,
6519  * or a command line pipe mechanism using the '|' AND background
6520  * command execution '&'.  All of these capabilities are provided to any
6521  * C program which calls this procedure as the first thing in the
6522  * main program.
6523  * The piping mechanism will probably work with almost any 'filter' type
6524  * of program.  With suitable modification, it may useful for other
6525  * portability problems as well.
6526  *
6527  * Author:  Mark Pizzolato      mark@infocomm.com
6528  */
6529 struct list_item
6530     {
6531     struct list_item *next;
6532     char *value;
6533     };
6534
6535 static void add_item(struct list_item **head,
6536                      struct list_item **tail,
6537                      char *value,
6538                      int *count);
6539
6540 static void mp_expand_wild_cards(pTHX_ char *item,
6541                                 struct list_item **head,
6542                                 struct list_item **tail,
6543                                 int *count);
6544
6545 static int background_process(pTHX_ int argc, char **argv);
6546
6547 static void pipe_and_fork(pTHX_ char **cmargv);
6548
6549 /*{{{ void getredirection(int *ac, char ***av)*/
6550 static void
6551 mp_getredirection(pTHX_ int *ac, char ***av)
6552 /*
6553  * Process vms redirection arg's.  Exit if any error is seen.
6554  * If getredirection() processes an argument, it is erased
6555  * from the vector.  getredirection() returns a new argc and argv value.
6556  * In the event that a background command is requested (by a trailing "&"),
6557  * this routine creates a background subprocess, and simply exits the program.
6558  *
6559  * Warning: do not try to simplify the code for vms.  The code
6560  * presupposes that getredirection() is called before any data is
6561  * read from stdin or written to stdout.
6562  *
6563  * Normal usage is as follows:
6564  *
6565  *      main(argc, argv)
6566  *      int             argc;
6567  *      char            *argv[];
6568  *      {
6569  *              getredirection(&argc, &argv);
6570  *      }
6571  */
6572 {
6573     int                 argc = *ac;     /* Argument Count         */
6574     char                **argv = *av;   /* Argument Vector        */
6575     char                *ap;            /* Argument pointer       */
6576     int                 j;              /* argv[] index           */
6577     int                 item_count = 0; /* Count of Items in List */
6578     struct list_item    *list_head = 0; /* First Item in List       */
6579     struct list_item    *list_tail;     /* Last Item in List        */
6580     char                *in = NULL;     /* Input File Name          */
6581     char                *out = NULL;    /* Output File Name         */
6582     char                *outmode = "w"; /* Mode to Open Output File */
6583     char                *err = NULL;    /* Error File Name          */
6584     char                *errmode = "w"; /* Mode to Open Error File  */
6585     int                 cmargc = 0;     /* Piped Command Arg Count  */
6586     char                **cmargv = NULL;/* Piped Command Arg Vector */
6587
6588     /*
6589      * First handle the case where the last thing on the line ends with
6590      * a '&'.  This indicates the desire for the command to be run in a
6591      * subprocess, so we satisfy that desire.
6592      */
6593     ap = argv[argc-1];
6594     if (0 == strcmp("&", ap))
6595        exit(background_process(aTHX_ --argc, argv));
6596     if (*ap && '&' == ap[strlen(ap)-1])
6597         {
6598         ap[strlen(ap)-1] = '\0';
6599        exit(background_process(aTHX_ argc, argv));
6600         }
6601     /*
6602      * Now we handle the general redirection cases that involve '>', '>>',
6603      * '<', and pipes '|'.
6604      */
6605     for (j = 0; j < argc; ++j)
6606         {
6607         if (0 == strcmp("<", argv[j]))
6608             {
6609             if (j+1 >= argc)
6610                 {
6611                 fprintf(stderr,"No input file after < on command line");
6612                 exit(LIB$_WRONUMARG);
6613                 }
6614             in = argv[++j];
6615             continue;
6616             }
6617         if ('<' == *(ap = argv[j]))
6618             {
6619             in = 1 + ap;
6620             continue;
6621             }
6622         if (0 == strcmp(">", ap))
6623             {
6624             if (j+1 >= argc)
6625                 {
6626                 fprintf(stderr,"No output file after > on command line");
6627                 exit(LIB$_WRONUMARG);
6628                 }
6629             out = argv[++j];
6630             continue;
6631             }
6632         if ('>' == *ap)
6633             {
6634             if ('>' == ap[1])
6635                 {
6636                 outmode = "a";
6637                 if ('\0' == ap[2])
6638                     out = argv[++j];
6639                 else
6640                     out = 2 + ap;
6641                 }
6642             else
6643                 out = 1 + ap;
6644             if (j >= argc)
6645                 {
6646                 fprintf(stderr,"No output file after > or >> on command line");
6647                 exit(LIB$_WRONUMARG);
6648                 }
6649             continue;
6650             }
6651         if (('2' == *ap) && ('>' == ap[1]))
6652             {
6653             if ('>' == ap[2])
6654                 {
6655                 errmode = "a";
6656                 if ('\0' == ap[3])
6657                     err = argv[++j];
6658                 else
6659                     err = 3 + ap;
6660                 }
6661             else
6662                 if ('\0' == ap[2])
6663                     err = argv[++j];
6664                 else
6665                     err = 2 + ap;
6666             if (j >= argc)
6667                 {
6668                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6669                 exit(LIB$_WRONUMARG);
6670                 }
6671             continue;
6672             }
6673         if (0 == strcmp("|", argv[j]))
6674             {
6675             if (j+1 >= argc)
6676                 {
6677                 fprintf(stderr,"No command into which to pipe on command line");
6678                 exit(LIB$_WRONUMARG);
6679                 }
6680             cmargc = argc-(j+1);
6681             cmargv = &argv[j+1];
6682             argc = j;
6683             continue;
6684             }
6685         if ('|' == *(ap = argv[j]))
6686             {
6687             ++argv[j];
6688             cmargc = argc-j;
6689             cmargv = &argv[j];
6690             argc = j;
6691             continue;
6692             }
6693         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6694         }
6695     /*
6696      * Allocate and fill in the new argument vector, Some Unix's terminate
6697      * the list with an extra null pointer.
6698      */
6699     Newx(argv, item_count+1, char *);
6700     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6701     *av = argv;
6702     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6703         argv[j] = list_head->value;
6704     *ac = item_count;
6705     if (cmargv != NULL)
6706         {
6707         if (out != NULL)
6708             {
6709             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6710             exit(LIB$_INVARGORD);
6711             }
6712         pipe_and_fork(aTHX_ cmargv);
6713         }
6714
6715     /* Check for input from a pipe (mailbox) */
6716
6717     if (in == NULL && 1 == isapipe(0))
6718         {
6719         char mbxname[L_tmpnam];
6720         long int bufsize;
6721         long int dvi_item = DVI$_DEVBUFSIZ;
6722         $DESCRIPTOR(mbxnam, "");
6723         $DESCRIPTOR(mbxdevnam, "");
6724
6725         /* Input from a pipe, reopen it in binary mode to disable       */
6726         /* carriage control processing.                                 */
6727
6728         fgetname(stdin, mbxname);
6729         mbxnam.dsc$a_pointer = mbxname;
6730         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6731         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6732         mbxdevnam.dsc$a_pointer = mbxname;
6733         mbxdevnam.dsc$w_length = sizeof(mbxname);
6734         dvi_item = DVI$_DEVNAM;
6735         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6736         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6737         set_errno(0);
6738         set_vaxc_errno(1);
6739         freopen(mbxname, "rb", stdin);
6740         if (errno != 0)
6741             {
6742             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6743             exit(vaxc$errno);
6744             }
6745         }
6746     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6747         {
6748         fprintf(stderr,"Can't open input file %s as stdin",in);
6749         exit(vaxc$errno);
6750         }
6751     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6752         {
6753         fprintf(stderr,"Can't open output file %s as stdout",out);
6754         exit(vaxc$errno);
6755         }
6756         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6757
6758     if (err != NULL) {
6759         if (strcmp(err,"&1") == 0) {
6760             dup2(fileno(stdout), fileno(stderr));
6761             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6762         } else {
6763         FILE *tmperr;
6764         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6765             {
6766             fprintf(stderr,"Can't open error file %s as stderr",err);
6767             exit(vaxc$errno);
6768             }
6769             fclose(tmperr);
6770            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6771                 {
6772                 exit(vaxc$errno);
6773                 }
6774             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6775         }
6776         }
6777 #ifdef ARGPROC_DEBUG
6778     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6779     for (j = 0; j < *ac;  ++j)
6780         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6781 #endif
6782    /* Clear errors we may have hit expanding wildcards, so they don't
6783       show up in Perl's $! later */
6784    set_errno(0); set_vaxc_errno(1);
6785 }  /* end of getredirection() */
6786 /*}}}*/
6787
6788 static void add_item(struct list_item **head,
6789                      struct list_item **tail,
6790                      char *value,
6791                      int *count)
6792 {
6793     if (*head == 0)
6794         {
6795         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6796         *tail = *head;
6797         }
6798     else {
6799         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6800         *tail = (*tail)->next;
6801         }
6802     (*tail)->value = value;
6803     ++(*count);
6804 }
6805
6806 static void mp_expand_wild_cards(pTHX_ char *item,
6807                               struct list_item **head,
6808                               struct list_item **tail,
6809                               int *count)
6810 {
6811 int expcount = 0;
6812 unsigned long int context = 0;
6813 int isunix = 0;
6814 int item_len = 0;
6815 char *had_version;
6816 char *had_device;
6817 int had_directory;
6818 char *devdir,*cp;
6819 char *vmsspec;
6820 $DESCRIPTOR(filespec, "");
6821 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6822 $DESCRIPTOR(resultspec, "");
6823 unsigned long int lff_flags = 0;
6824 int sts;
6825
6826 #ifdef VMS_LONGNAME_SUPPORT
6827     lff_flags = LIB$M_FIL_LONG_NAMES;
6828 #endif
6829
6830     for (cp = item; *cp; cp++) {
6831         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6832         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6833     }
6834     if (!*cp || isspace(*cp))
6835         {
6836         add_item(head, tail, item, count);
6837         return;
6838         }
6839     else
6840         {
6841      /* "double quoted" wild card expressions pass as is */
6842      /* From DCL that means using e.g.:                  */
6843      /* perl program """perl.*"""                        */
6844      item_len = strlen(item);
6845      if ( '"' == *item && '"' == item[item_len-1] )
6846        {
6847        item++;
6848        item[item_len-2] = '\0';
6849        add_item(head, tail, item, count);
6850        return;
6851        }
6852      }
6853     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6854     resultspec.dsc$b_class = DSC$K_CLASS_D;
6855     resultspec.dsc$a_pointer = NULL;
6856     Newx(vmsspec, VMS_MAXRSS, char);
6857     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6858       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6859     if (!isunix || !filespec.dsc$a_pointer)
6860       filespec.dsc$a_pointer = item;
6861     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6862     /*
6863      * Only return version specs, if the caller specified a version
6864      */
6865     had_version = strchr(item, ';');
6866     /*
6867      * Only return device and directory specs, if the caller specifed either.
6868      */
6869     had_device = strchr(item, ':');
6870     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6871
6872     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6873                                  (&filespec, &resultspec, &context,
6874                                   &defaultspec, 0, 0, &lff_flags)))
6875         {
6876         char *string;
6877         char *c;
6878
6879         Newx(string,resultspec.dsc$w_length+1,char);
6880         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6881         string[resultspec.dsc$w_length] = '\0';
6882         if (NULL == had_version)
6883             *(strrchr(string, ';')) = '\0';
6884         if ((!had_directory) && (had_device == NULL))
6885             {
6886             if (NULL == (devdir = strrchr(string, ']')))
6887                 devdir = strrchr(string, '>');
6888             strcpy(string, devdir + 1);
6889             }
6890         /*
6891          * Be consistent with what the C RTL has already done to the rest of
6892          * the argv items and lowercase all of these names.
6893          */
6894         if (!decc_efs_case_preserve) {
6895             for (c = string; *c; ++c)
6896             if (isupper(*c))
6897                 *c = tolower(*c);
6898         }
6899         if (isunix) trim_unixpath(string,item,1);
6900         add_item(head, tail, string, count);
6901         ++expcount;
6902     }
6903     Safefree(vmsspec);
6904     if (sts != RMS$_NMF)
6905         {
6906         set_vaxc_errno(sts);
6907         switch (sts)
6908             {
6909             case RMS$_FNF: case RMS$_DNF:
6910                 set_errno(ENOENT); break;
6911             case RMS$_DIR:
6912                 set_errno(ENOTDIR); break;
6913             case RMS$_DEV:
6914                 set_errno(ENODEV); break;
6915             case RMS$_FNM: case RMS$_SYN:
6916                 set_errno(EINVAL); break;
6917             case RMS$_PRV:
6918                 set_errno(EACCES); break;
6919             default:
6920                 _ckvmssts_noperl(sts);
6921             }
6922         }
6923     if (expcount == 0)
6924         add_item(head, tail, item, count);
6925     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6926     _ckvmssts_noperl(lib$find_file_end(&context));
6927 }
6928
6929 static int child_st[2];/* Event Flag set when child process completes   */
6930
6931 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6932
6933 static unsigned long int exit_handler(int *status)
6934 {
6935 short iosb[4];
6936
6937     if (0 == child_st[0])
6938         {
6939 #ifdef ARGPROC_DEBUG
6940         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6941 #endif
6942         fflush(stdout);     /* Have to flush pipe for binary data to    */
6943                             /* terminate properly -- <tp@mccall.com>    */
6944         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6945         sys$dassgn(child_chan);
6946         fclose(stdout);
6947         sys$synch(0, child_st);
6948         }
6949     return(1);
6950 }
6951
6952 static void sig_child(int chan)
6953 {
6954 #ifdef ARGPROC_DEBUG
6955     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6956 #endif
6957     if (child_st[0] == 0)
6958         child_st[0] = 1;
6959 }
6960
6961 static struct exit_control_block exit_block =
6962     {
6963     0,
6964     exit_handler,
6965     1,
6966     &exit_block.exit_status,
6967     0
6968     };
6969
6970 static void
6971 pipe_and_fork(pTHX_ char **cmargv)
6972 {
6973     PerlIO *fp;
6974     struct dsc$descriptor_s *vmscmd;
6975     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6976     int sts, j, l, ismcr, quote, tquote = 0;
6977
6978     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6979     vms_execfree(vmscmd);
6980
6981     j = l = 0;
6982     p = subcmd;
6983     q = cmargv[0];
6984     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6985               && toupper(*(q+2)) == 'R' && !*(q+3);
6986
6987     while (q && l < MAX_DCL_LINE_LENGTH) {
6988         if (!*q) {
6989             if (j > 0 && quote) {
6990                 *p++ = '"';
6991                 l++;
6992             }
6993             q = cmargv[++j];
6994             if (q) {
6995                 if (ismcr && j > 1) quote = 1;
6996                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6997                 *p++ = ' ';
6998                 l++;
6999                 if (quote || tquote) {
7000                     *p++ = '"';
7001                     l++;
7002                 }
7003         }
7004         } else {
7005             if ((quote||tquote) && *q == '"') {
7006                 *p++ = '"';
7007                 l++;
7008         }
7009             *p++ = *q++;
7010             l++;
7011         }
7012     }
7013     *p = '\0';
7014
7015     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7016     if (fp == Nullfp) {
7017         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7018         }
7019 }
7020
7021 static int background_process(pTHX_ int argc, char **argv)
7022 {
7023 char command[MAX_DCL_SYMBOL + 1] = "$";
7024 $DESCRIPTOR(value, "");
7025 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7026 static $DESCRIPTOR(null, "NLA0:");
7027 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7028 char pidstring[80];
7029 $DESCRIPTOR(pidstr, "");
7030 int pid;
7031 unsigned long int flags = 17, one = 1, retsts;
7032 int len;
7033
7034     strcat(command, argv[0]);
7035     len = strlen(command);
7036     while (--argc && (len < MAX_DCL_SYMBOL))
7037         {
7038         strcat(command, " \"");
7039         strcat(command, *(++argv));
7040         strcat(command, "\"");
7041         len = strlen(command);
7042         }
7043     value.dsc$a_pointer = command;
7044     value.dsc$w_length = strlen(value.dsc$a_pointer);
7045     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7046     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7047     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7048         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7049     }
7050     else {
7051         _ckvmssts_noperl(retsts);
7052     }
7053 #ifdef ARGPROC_DEBUG
7054     PerlIO_printf(Perl_debug_log, "%s\n", command);
7055 #endif
7056     sprintf(pidstring, "%08X", pid);
7057     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7058     pidstr.dsc$a_pointer = pidstring;
7059     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7060     lib$set_symbol(&pidsymbol, &pidstr);
7061     return(SS$_NORMAL);
7062 }
7063 /*}}}*/
7064 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7065
7066
7067 /* OS-specific initialization at image activation (not thread startup) */
7068 /* Older VAXC header files lack these constants */
7069 #ifndef JPI$_RIGHTS_SIZE
7070 #  define JPI$_RIGHTS_SIZE 817
7071 #endif
7072 #ifndef KGB$M_SUBSYSTEM
7073 #  define KGB$M_SUBSYSTEM 0x8
7074 #endif
7075
7076 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7077
7078 /*{{{void vms_image_init(int *, char ***)*/
7079 void
7080 vms_image_init(int *argcp, char ***argvp)
7081 {
7082   char eqv[LNM$C_NAMLENGTH+1] = "";
7083   unsigned int len, tabct = 8, tabidx = 0;
7084   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7085   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7086   unsigned short int dummy, rlen;
7087   struct dsc$descriptor_s **tabvec;
7088 #if defined(PERL_IMPLICIT_CONTEXT)
7089   pTHX = NULL;
7090 #endif
7091   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7092                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7093                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7094                                  {          0,                0,    0,      0} };
7095
7096 #ifdef KILL_BY_SIGPRC
7097     Perl_csighandler_init();
7098 #endif
7099
7100   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7101   _ckvmssts_noperl(iosb[0]);
7102   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7103     if (iprv[i]) {           /* Running image installed with privs? */
7104       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7105       will_taint = TRUE;
7106       break;
7107     }
7108   }
7109   /* Rights identifiers might trigger tainting as well. */
7110   if (!will_taint && (rlen || rsz)) {
7111     while (rlen < rsz) {
7112       /* We didn't get all the identifiers on the first pass.  Allocate a
7113        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7114        * were needed to hold all identifiers at time of last call; we'll
7115        * allocate that many unsigned long ints), and go back and get 'em.
7116        * If it gave us less than it wanted to despite ample buffer space,
7117        * something's broken.  Is your system missing a system identifier?
7118        */
7119       if (rsz <= jpilist[1].buflen) {
7120          /* Perl_croak accvios when used this early in startup. */
7121          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7122                          rsz, (unsigned long) jpilist[1].buflen,
7123                          "Check your rights database for corruption.\n");
7124          exit(SS$_ABORT);
7125       }
7126       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7127       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7128       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7129       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7130       _ckvmssts_noperl(iosb[0]);
7131     }
7132     mask = jpilist[1].bufadr;
7133     /* Check attribute flags for each identifier (2nd longword); protected
7134      * subsystem identifiers trigger tainting.
7135      */
7136     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7137       if (mask[i] & KGB$M_SUBSYSTEM) {
7138         will_taint = TRUE;
7139         break;
7140       }
7141     }
7142     if (mask != rlst) Safefree(mask);
7143   }
7144
7145   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7146    * logical, some versions of the CRTL will add a phanthom /000000/
7147    * directory.  This needs to be removed.
7148    */
7149   if (decc_filename_unix_report) {
7150   char * zeros;
7151   int ulen;
7152     ulen = strlen(argvp[0][0]);
7153     if (ulen > 7) {
7154       zeros = strstr(argvp[0][0], "/000000/");
7155       if (zeros != NULL) {
7156         int mlen;
7157         mlen = ulen - (zeros - argvp[0][0]) - 7;
7158         memmove(zeros, &zeros[7], mlen);
7159         ulen = ulen - 7;
7160         argvp[0][0][ulen] = '\0';
7161       }
7162     }
7163     /* It also may have a trailing dot that needs to be removed otherwise
7164      * it will be converted to VMS mode incorrectly.
7165      */
7166     ulen--;
7167     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7168       argvp[0][0][ulen] = '\0';
7169   }
7170
7171   /* We need to use this hack to tell Perl it should run with tainting,
7172    * since its tainting flag may be part of the PL_curinterp struct, which
7173    * hasn't been allocated when vms_image_init() is called.
7174    */
7175   if (will_taint) {
7176     char **newargv, **oldargv;
7177     oldargv = *argvp;
7178     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7179     newargv[0] = oldargv[0];
7180     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7181     strcpy(newargv[1], "-T");
7182     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7183     (*argcp)++;
7184     newargv[*argcp] = NULL;
7185     /* We orphan the old argv, since we don't know where it's come from,
7186      * so we don't know how to free it.
7187      */
7188     *argvp = newargv;
7189   }
7190   else {  /* Did user explicitly request tainting? */
7191     int i;
7192     char *cp, **av = *argvp;
7193     for (i = 1; i < *argcp; i++) {
7194       if (*av[i] != '-') break;
7195       for (cp = av[i]+1; *cp; cp++) {
7196         if (*cp == 'T') { will_taint = 1; break; }
7197         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7198                   strchr("DFIiMmx",*cp)) break;
7199       }
7200       if (will_taint) break;
7201     }
7202   }
7203
7204   for (tabidx = 0;
7205        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7206        tabidx++) {
7207     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7208     else if (tabidx >= tabct) {
7209       tabct += 8;
7210       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7211     }
7212     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7213     tabvec[tabidx]->dsc$w_length  = 0;
7214     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7215     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7216     tabvec[tabidx]->dsc$a_pointer = NULL;
7217     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7218   }
7219   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7220
7221   getredirection(argcp,argvp);
7222 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7223   {
7224 # include <reentrancy.h>
7225   decc$set_reentrancy(C$C_MULTITHREAD);
7226   }
7227 #endif
7228   return;
7229 }
7230 /*}}}*/
7231
7232
7233 /* trim_unixpath()
7234  * Trim Unix-style prefix off filespec, so it looks like what a shell
7235  * glob expansion would return (i.e. from specified prefix on, not
7236  * full path).  Note that returned filespec is Unix-style, regardless
7237  * of whether input filespec was VMS-style or Unix-style.
7238  *
7239  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7240  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7241  * vector of options; at present, only bit 0 is used, and if set tells
7242  * trim unixpath to try the current default directory as a prefix when
7243  * presented with a possibly ambiguous ... wildcard.
7244  *
7245  * Returns !=0 on success, with trimmed filespec replacing contents of
7246  * fspec, and 0 on failure, with contents of fpsec unchanged.
7247  */
7248 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7249 int
7250 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7251 {
7252   char *unixified, *unixwild,
7253        *template, *base, *end, *cp1, *cp2;
7254   register int tmplen, reslen = 0, dirs = 0;
7255
7256   Newx(unixwild, VMS_MAXRSS, char);
7257   if (!wildspec || !fspec) return 0;
7258   template = unixwild;
7259   if (strpbrk(wildspec,"]>:") != NULL) {
7260     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7261         Safefree(unixwild);
7262         return 0;
7263     }
7264   }
7265   else {
7266     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7267     unixwild[VMS_MAXRSS-1] = 0;
7268   }
7269   Newx(unixified, VMS_MAXRSS, char);
7270   if (strpbrk(fspec,"]>:") != NULL) {
7271     if (do_tounixspec(fspec,unixified,0) == NULL) {
7272         Safefree(unixwild);
7273         Safefree(unixified);
7274         return 0;
7275     }
7276     else base = unixified;
7277     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7278      * check to see that final result fits into (isn't longer than) fspec */
7279     reslen = strlen(fspec);
7280   }
7281   else base = fspec;
7282
7283   /* No prefix or absolute path on wildcard, so nothing to remove */
7284   if (!*template || *template == '/') {
7285     Safefree(unixwild);
7286     if (base == fspec) {
7287         Safefree(unixified);
7288         return 1;
7289     }
7290     tmplen = strlen(unixified);
7291     if (tmplen > reslen) {
7292         Safefree(unixified);
7293         return 0;  /* not enough space */
7294     }
7295     /* Copy unixified resultant, including trailing NUL */
7296     memmove(fspec,unixified,tmplen+1);
7297     Safefree(unixified);
7298     return 1;
7299   }
7300
7301   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7302   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7303     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7304     for (cp1 = end ;cp1 >= base; cp1--)
7305       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7306         { cp1++; break; }
7307     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7308     Safefree(unixified);
7309     Safefree(unixwild);
7310     return 1;
7311   }
7312   else {
7313     char *tpl, *lcres;
7314     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7315     int ells = 1, totells, segdirs, match;
7316     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7317                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7318
7319     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7320     totells = ells;
7321     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7322     Newx(tpl, VMS_MAXRSS, char);
7323     if (ellipsis == template && opts & 1) {
7324       /* Template begins with an ellipsis.  Since we can't tell how many
7325        * directory names at the front of the resultant to keep for an
7326        * arbitrary starting point, we arbitrarily choose the current
7327        * default directory as a starting point.  If it's there as a prefix,
7328        * clip it off.  If not, fall through and act as if the leading
7329        * ellipsis weren't there (i.e. return shortest possible path that
7330        * could match template).
7331        */
7332       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7333           Safefree(tpl);
7334           Safefree(unixified);
7335           Safefree(unixwild);
7336           return 0;
7337       }
7338       if (!decc_efs_case_preserve) {
7339         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7340           if (_tolower(*cp1) != _tolower(*cp2)) break;
7341       }
7342       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7343       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7344       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7345         memmove(fspec,cp2+1,end - cp2);
7346         Safefree(unixified);
7347         Safefree(unixwild);
7348         Safefree(tpl);
7349         return 1;
7350       }
7351     }
7352     /* First off, back up over constant elements at end of path */
7353     if (dirs) {
7354       for (front = end ; front >= base; front--)
7355          if (*front == '/' && !dirs--) { front++; break; }
7356     }
7357     Newx(lcres, VMS_MAXRSS, char);
7358     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7359          cp1++,cp2++) {
7360             if (!decc_efs_case_preserve) {
7361                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7362             }
7363             else {
7364                 *cp2 = *cp1;
7365             }
7366     }
7367     if (cp1 != '\0') {
7368         Safefree(unixified);
7369         Safefree(unixwild);
7370         Safefree(lcres);
7371         Safefree(tpl);
7372         return 0;  /* Path too long. */
7373     }
7374     lcend = cp2;
7375     *cp2 = '\0';  /* Pick up with memcpy later */
7376     lcfront = lcres + (front - base);
7377     /* Now skip over each ellipsis and try to match the path in front of it. */
7378     while (ells--) {
7379       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7380         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7381             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7382       if (cp1 < template) break; /* template started with an ellipsis */
7383       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7384         ellipsis = cp1; continue;
7385       }
7386       wilddsc.dsc$a_pointer = tpl;
7387       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7388       nextell = cp1;
7389       for (segdirs = 0, cp2 = tpl;
7390            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7391            cp1++, cp2++) {
7392          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7393          else {
7394             if (!decc_efs_case_preserve) {
7395               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7396             }
7397             else {
7398               *cp2 = *cp1;  /* else preserve case for match */
7399             }
7400          }
7401          if (*cp2 == '/') segdirs++;
7402       }
7403       if (cp1 != ellipsis - 1) {
7404           Safefree(unixified);
7405           Safefree(unixwild);
7406           Safefree(lcres);
7407           Safefree(tpl);
7408           return 0; /* Path too long */
7409       }
7410       /* Back up at least as many dirs as in template before matching */
7411       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7412         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7413       for (match = 0; cp1 > lcres;) {
7414         resdsc.dsc$a_pointer = cp1;
7415         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7416           match++;
7417           if (match == 1) lcfront = cp1;
7418         }
7419         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7420       }
7421       if (!match) {
7422         Safefree(unixified);
7423         Safefree(unixwild);
7424         Safefree(lcres);
7425         Safefree(tpl);
7426         return 0;  /* Can't find prefix ??? */
7427       }
7428       if (match > 1 && opts & 1) {
7429         /* This ... wildcard could cover more than one set of dirs (i.e.
7430          * a set of similar dir names is repeated).  If the template
7431          * contains more than 1 ..., upstream elements could resolve the
7432          * ambiguity, but it's not worth a full backtracking setup here.
7433          * As a quick heuristic, clip off the current default directory
7434          * if it's present to find the trimmed spec, else use the
7435          * shortest string that this ... could cover.
7436          */
7437         char def[NAM$C_MAXRSS+1], *st;
7438
7439         if (getcwd(def, sizeof def,0) == NULL) {
7440             Safefree(unixified);
7441             Safefree(unixwild);
7442             Safefree(lcres);
7443             Safefree(tpl);
7444             return 0;
7445         }
7446         if (!decc_efs_case_preserve) {
7447           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7448             if (_tolower(*cp1) != _tolower(*cp2)) break;
7449         }
7450         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7451         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7452         if (*cp1 == '\0' && *cp2 == '/') {
7453           memmove(fspec,cp2+1,end - cp2);
7454           Safefree(lcres);
7455           Safefree(unixified);
7456           Safefree(unixwild);
7457           Safefree(tpl);
7458           return 1;
7459         }
7460         /* Nope -- stick with lcfront from above and keep going. */
7461       }
7462     }
7463     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7464     Safefree(unixified);
7465     Safefree(unixwild);
7466     Safefree(lcres);
7467     Safefree(tpl);
7468     return 1;
7469     ellipsis = nextell;
7470   }
7471
7472 }  /* end of trim_unixpath() */
7473 /*}}}*/
7474
7475
7476 /*
7477  *  VMS readdir() routines.
7478  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7479  *
7480  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7481  *  Minor modifications to original routines.
7482  */
7483
7484 /* readdir may have been redefined by reentr.h, so make sure we get
7485  * the local version for what we do here.
7486  */
7487 #ifdef readdir
7488 # undef readdir
7489 #endif
7490 #if !defined(PERL_IMPLICIT_CONTEXT)
7491 # define readdir Perl_readdir
7492 #else
7493 # define readdir(a) Perl_readdir(aTHX_ a)
7494 #endif
7495
7496     /* Number of elements in vms_versions array */
7497 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7498
7499 /*
7500  *  Open a directory, return a handle for later use.
7501  */
7502 /*{{{ DIR *opendir(char*name) */
7503 DIR *
7504 Perl_opendir(pTHX_ const char *name)
7505 {
7506     DIR *dd;
7507     char dir[NAM$C_MAXRSS+1];
7508     Stat_t sb;
7509
7510     if (do_tovmspath(name,dir,0) == NULL) {
7511       return NULL;
7512     }
7513     /* Check access before stat; otherwise stat does not
7514      * accurately report whether it's a directory.
7515      */
7516     if (!cando_by_name(S_IRUSR,0,dir)) {
7517       /* cando_by_name has already set errno */
7518       return NULL;
7519     }
7520     if (flex_stat(dir,&sb) == -1) return NULL;
7521     if (!S_ISDIR(sb.st_mode)) {
7522       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7523       return NULL;
7524     }
7525     /* Get memory for the handle, and the pattern. */
7526     Newx(dd,1,DIR);
7527     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7528
7529     /* Fill in the fields; mainly playing with the descriptor. */
7530     sprintf(dd->pattern, "%s*.*",dir);
7531     dd->context = 0;
7532     dd->count = 0;
7533     dd->vms_wantversions = 0;
7534     dd->pat.dsc$a_pointer = dd->pattern;
7535     dd->pat.dsc$w_length = strlen(dd->pattern);
7536     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7537     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7538 #if defined(USE_ITHREADS)
7539     Newx(dd->mutex,1,perl_mutex);
7540     MUTEX_INIT( (perl_mutex *) dd->mutex );
7541 #else
7542     dd->mutex = NULL;
7543 #endif
7544
7545     return dd;
7546 }  /* end of opendir() */
7547 /*}}}*/
7548
7549 /*
7550  *  Set the flag to indicate we want versions or not.
7551  */
7552 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7553 void
7554 vmsreaddirversions(DIR *dd, int flag)
7555 {
7556     dd->vms_wantversions = flag;
7557 }
7558 /*}}}*/
7559
7560 /*
7561  *  Free up an opened directory.
7562  */
7563 /*{{{ void closedir(DIR *dd)*/
7564 void
7565 Perl_closedir(DIR *dd)
7566 {
7567     int sts;
7568
7569     sts = lib$find_file_end(&dd->context);
7570     Safefree(dd->pattern);
7571 #if defined(USE_ITHREADS)
7572     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7573     Safefree(dd->mutex);
7574 #endif
7575     Safefree(dd);
7576 }
7577 /*}}}*/
7578
7579 /*
7580  *  Collect all the version numbers for the current file.
7581  */
7582 static void
7583 collectversions(pTHX_ DIR *dd)
7584 {
7585     struct dsc$descriptor_s     pat;
7586     struct dsc$descriptor_s     res;
7587     struct dirent *e;
7588     char *p, *text, buff[sizeof dd->entry.d_name];
7589     int i;
7590     unsigned long context, tmpsts;
7591
7592     /* Convenient shorthand. */
7593     e = &dd->entry;
7594
7595     /* Add the version wildcard, ignoring the "*.*" put on before */
7596     i = strlen(dd->pattern);
7597     Newx(text,i + e->d_namlen + 3,char);
7598     strcpy(text, dd->pattern);
7599     sprintf(&text[i - 3], "%s;*", e->d_name);
7600
7601     /* Set up the pattern descriptor. */
7602     pat.dsc$a_pointer = text;
7603     pat.dsc$w_length = i + e->d_namlen - 1;
7604     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7605     pat.dsc$b_class = DSC$K_CLASS_S;
7606
7607     /* Set up result descriptor. */
7608     res.dsc$a_pointer = buff;
7609     res.dsc$w_length = sizeof buff - 2;
7610     res.dsc$b_dtype = DSC$K_DTYPE_T;
7611     res.dsc$b_class = DSC$K_CLASS_S;
7612
7613     /* Read files, collecting versions. */
7614     for (context = 0, e->vms_verscount = 0;
7615          e->vms_verscount < VERSIZE(e);
7616          e->vms_verscount++) {
7617         tmpsts = lib$find_file(&pat, &res, &context);
7618         if (tmpsts == RMS$_NMF || context == 0) break;
7619         _ckvmssts(tmpsts);
7620         buff[sizeof buff - 1] = '\0';
7621         if ((p = strchr(buff, ';')))
7622             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7623         else
7624             e->vms_versions[e->vms_verscount] = -1;
7625     }
7626
7627     _ckvmssts(lib$find_file_end(&context));
7628     Safefree(text);
7629
7630 }  /* end of collectversions() */
7631
7632 /*
7633  *  Read the next entry from the directory.
7634  */
7635 /*{{{ struct dirent *readdir(DIR *dd)*/
7636 struct dirent *
7637 Perl_readdir(pTHX_ DIR *dd)
7638 {
7639     struct dsc$descriptor_s     res;
7640     char *p, buff[sizeof dd->entry.d_name];
7641     unsigned long int tmpsts;
7642
7643     /* Set up result descriptor, and get next file. */
7644     res.dsc$a_pointer = buff;
7645     res.dsc$w_length = sizeof buff - 2;
7646     res.dsc$b_dtype = DSC$K_DTYPE_T;
7647     res.dsc$b_class = DSC$K_CLASS_S;
7648     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7649     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7650     if (!(tmpsts & 1)) {
7651       set_vaxc_errno(tmpsts);
7652       switch (tmpsts) {
7653         case RMS$_PRV:
7654           set_errno(EACCES); break;
7655         case RMS$_DEV:
7656           set_errno(ENODEV); break;
7657         case RMS$_DIR:
7658           set_errno(ENOTDIR); break;
7659         case RMS$_FNF: case RMS$_DNF:
7660           set_errno(ENOENT); break;
7661         default:
7662           set_errno(EVMSERR);
7663       }
7664       return NULL;
7665     }
7666     dd->count++;
7667     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7668     if (!decc_efs_case_preserve) {
7669       buff[sizeof buff - 1] = '\0';
7670       for (p = buff; *p; p++) *p = _tolower(*p);
7671       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7672       *p = '\0';
7673     }
7674     else {
7675       /* we don't want to force to lowercase, just null terminate */
7676       buff[res.dsc$w_length] = '\0';
7677     }
7678     for (p = buff; *p; p++) *p = _tolower(*p);
7679     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7680     *p = '\0';
7681
7682     /* Skip any directory component and just copy the name. */
7683     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7684     else strcpy(dd->entry.d_name, buff);
7685
7686     /* Clobber the version. */
7687     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7688
7689     dd->entry.d_namlen = strlen(dd->entry.d_name);
7690     dd->entry.vms_verscount = 0;
7691     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7692     return &dd->entry;
7693
7694 }  /* end of readdir() */
7695 /*}}}*/
7696
7697 /*
7698  *  Read the next entry from the directory -- thread-safe version.
7699  */
7700 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7701 int
7702 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
7703 {
7704     int retval;
7705
7706     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7707
7708     entry = readdir(dd);
7709     *result = entry;
7710     retval = ( *result == NULL ? errno : 0 );
7711
7712     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7713
7714     return retval;
7715
7716 }  /* end of readdir_r() */
7717 /*}}}*/
7718
7719 /*
7720  *  Return something that can be used in a seekdir later.
7721  */
7722 /*{{{ long telldir(DIR *dd)*/
7723 long
7724 Perl_telldir(DIR *dd)
7725 {
7726     return dd->count;
7727 }
7728 /*}}}*/
7729
7730 /*
7731  *  Return to a spot where we used to be.  Brute force.
7732  */
7733 /*{{{ void seekdir(DIR *dd,long count)*/
7734 void
7735 Perl_seekdir(pTHX_ DIR *dd, long count)
7736 {
7737     int vms_wantversions;
7738
7739     /* If we haven't done anything yet... */
7740     if (dd->count == 0)
7741         return;
7742
7743     /* Remember some state, and clear it. */
7744     vms_wantversions = dd->vms_wantversions;
7745     dd->vms_wantversions = 0;
7746     _ckvmssts(lib$find_file_end(&dd->context));
7747     dd->context = 0;
7748
7749     /* The increment is in readdir(). */
7750     for (dd->count = 0; dd->count < count; )
7751         readdir(dd);
7752
7753     dd->vms_wantversions = vms_wantversions;
7754
7755 }  /* end of seekdir() */
7756 /*}}}*/
7757
7758 /* VMS subprocess management
7759  *
7760  * my_vfork() - just a vfork(), after setting a flag to record that
7761  * the current script is trying a Unix-style fork/exec.
7762  *
7763  * vms_do_aexec() and vms_do_exec() are called in response to the
7764  * perl 'exec' function.  If this follows a vfork call, then they
7765  * call out the regular perl routines in doio.c which do an
7766  * execvp (for those who really want to try this under VMS).
7767  * Otherwise, they do exactly what the perl docs say exec should
7768  * do - terminate the current script and invoke a new command
7769  * (See below for notes on command syntax.)
7770  *
7771  * do_aspawn() and do_spawn() implement the VMS side of the perl
7772  * 'system' function.
7773  *
7774  * Note on command arguments to perl 'exec' and 'system': When handled
7775  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7776  * are concatenated to form a DCL command string.  If the first arg
7777  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7778  * the command string is handed off to DCL directly.  Otherwise,
7779  * the first token of the command is taken as the filespec of an image
7780  * to run.  The filespec is expanded using a default type of '.EXE' and
7781  * the process defaults for device, directory, etc., and if found, the resultant
7782  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7783  * the command string as parameters.  This is perhaps a bit complicated,
7784  * but I hope it will form a happy medium between what VMS folks expect
7785  * from lib$spawn and what Unix folks expect from exec.
7786  */
7787
7788 static int vfork_called;
7789
7790 /*{{{int my_vfork()*/
7791 int
7792 my_vfork()
7793 {
7794   vfork_called++;
7795   return vfork();
7796 }
7797 /*}}}*/
7798
7799
7800 static void
7801 vms_execfree(struct dsc$descriptor_s *vmscmd)
7802 {
7803   if (vmscmd) {
7804       if (vmscmd->dsc$a_pointer) {
7805           Safefree(vmscmd->dsc$a_pointer);
7806       }
7807       Safefree(vmscmd);
7808   }
7809 }
7810
7811 static char *
7812 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7813 {
7814   char *junk, *tmps = Nullch;
7815   register size_t cmdlen = 0;
7816   size_t rlen;
7817   register SV **idx;
7818   STRLEN n_a;
7819
7820   idx = mark;
7821   if (really) {
7822     tmps = SvPV(really,rlen);
7823     if (*tmps) {
7824       cmdlen += rlen + 1;
7825       idx++;
7826     }
7827   }
7828
7829   for (idx++; idx <= sp; idx++) {
7830     if (*idx) {
7831       junk = SvPVx(*idx,rlen);
7832       cmdlen += rlen ? rlen + 1 : 0;
7833     }
7834   }
7835   Newx(PL_Cmd,cmdlen+1,char);
7836
7837   if (tmps && *tmps) {
7838     strcpy(PL_Cmd,tmps);
7839     mark++;
7840   }
7841   else *PL_Cmd = '\0';
7842   while (++mark <= sp) {
7843     if (*mark) {
7844       char *s = SvPVx(*mark,n_a);
7845       if (!*s) continue;
7846       if (*PL_Cmd) strcat(PL_Cmd," ");
7847       strcat(PL_Cmd,s);
7848     }
7849   }
7850   return PL_Cmd;
7851
7852 }  /* end of setup_argstr() */
7853
7854
7855 static unsigned long int
7856 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7857                    struct dsc$descriptor_s **pvmscmd)
7858 {
7859   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7860   char image_name[NAM$C_MAXRSS+1];
7861   char image_argv[NAM$C_MAXRSS+1];
7862   $DESCRIPTOR(defdsc,".EXE");
7863   $DESCRIPTOR(defdsc2,".");
7864   $DESCRIPTOR(resdsc,resspec);
7865   struct dsc$descriptor_s *vmscmd;
7866   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7867   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7868   register char *s, *rest, *cp, *wordbreak;
7869   char * cmd;
7870   int cmdlen;
7871   register int isdcl;
7872
7873   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7874
7875   /* Make a copy for modification */
7876   cmdlen = strlen(incmd);
7877   Newx(cmd, cmdlen+1, char);
7878   strncpy(cmd, incmd, cmdlen);
7879   cmd[cmdlen] = 0;
7880   image_name[0] = 0;
7881   image_argv[0] = 0;
7882
7883   vmscmd->dsc$a_pointer = NULL;
7884   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7885   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7886   vmscmd->dsc$w_length = 0;
7887   if (pvmscmd) *pvmscmd = vmscmd;
7888
7889   if (suggest_quote) *suggest_quote = 0;
7890
7891   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7892     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7893     Safefree(cmd);
7894   }
7895
7896   s = cmd;
7897
7898   while (*s && isspace(*s)) s++;
7899
7900   if (*s == '@' || *s == '$') {
7901     vmsspec[0] = *s;  rest = s + 1;
7902     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7903   }
7904   else { cp = vmsspec; rest = s; }
7905   if (*rest == '.' || *rest == '/') {
7906     char *cp2;
7907     for (cp2 = resspec;
7908          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7909          rest++, cp2++) *cp2 = *rest;
7910     *cp2 = '\0';
7911     if (do_tovmsspec(resspec,cp,0)) {
7912       s = vmsspec;
7913       if (*rest) {
7914         for (cp2 = vmsspec + strlen(vmsspec);
7915              *rest && cp2 - vmsspec < sizeof vmsspec;
7916              rest++, cp2++) *cp2 = *rest;
7917         *cp2 = '\0';
7918       }
7919     }
7920   }
7921   /* Intuit whether verb (first word of cmd) is a DCL command:
7922    *   - if first nonspace char is '@', it's a DCL indirection
7923    * otherwise
7924    *   - if verb contains a filespec separator, it's not a DCL command
7925    *   - if it doesn't, caller tells us whether to default to a DCL
7926    *     command, or to a local image unless told it's DCL (by leading '$')
7927    */
7928   if (*s == '@') {
7929       isdcl = 1;
7930       if (suggest_quote) *suggest_quote = 1;
7931   } else {
7932     register char *filespec = strpbrk(s,":<[.;");
7933     rest = wordbreak = strpbrk(s," \"\t/");
7934     if (!wordbreak) wordbreak = s + strlen(s);
7935     if (*s == '$') check_img = 0;
7936     if (filespec && (filespec < wordbreak)) isdcl = 0;
7937     else isdcl = !check_img;
7938   }
7939
7940   if (!isdcl) {
7941     imgdsc.dsc$a_pointer = s;
7942     imgdsc.dsc$w_length = wordbreak - s;
7943     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7944     if (!(retsts&1)) {
7945         _ckvmssts(lib$find_file_end(&cxt));
7946         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7947       if (!(retsts & 1) && *s == '$') {
7948         _ckvmssts(lib$find_file_end(&cxt));
7949         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7950         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7951         if (!(retsts&1)) {
7952           _ckvmssts(lib$find_file_end(&cxt));
7953           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7954         }
7955       }
7956     }
7957     _ckvmssts(lib$find_file_end(&cxt));
7958
7959     if (retsts & 1) {
7960       FILE *fp;
7961       s = resspec;
7962       while (*s && !isspace(*s)) s++;
7963       *s = '\0';
7964
7965       /* check that it's really not DCL with no file extension */
7966       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7967       if (fp) {
7968         char b[256] = {0,0,0,0};
7969         read(fileno(fp), b, 256);
7970         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7971         if (isdcl) {
7972           int shebang_len;
7973
7974           /* Check for script */
7975           shebang_len = 0;
7976           if ((b[0] == '#') && (b[1] == '!'))
7977              shebang_len = 2;
7978 #ifdef ALTERNATE_SHEBANG
7979           else {
7980             shebang_len = strlen(ALTERNATE_SHEBANG);
7981             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7982               char * perlstr;
7983                 perlstr = strstr("perl",b);
7984                 if (perlstr == NULL)
7985                   shebang_len = 0;
7986             }
7987             else
7988               shebang_len = 0;
7989           }
7990 #endif
7991
7992           if (shebang_len > 0) {
7993           int i;
7994           int j;
7995           char tmpspec[NAM$C_MAXRSS + 1];
7996
7997             i = shebang_len;
7998              /* Image is following after white space */
7999             /*--------------------------------------*/
8000             while (isprint(b[i]) && isspace(b[i]))
8001                 i++;
8002
8003             j = 0;
8004             while (isprint(b[i]) && !isspace(b[i])) {
8005                 tmpspec[j++] = b[i++];
8006                 if (j >= NAM$C_MAXRSS)
8007                    break;
8008             }
8009             tmpspec[j] = '\0';
8010
8011              /* There may be some default parameters to the image */
8012             /*---------------------------------------------------*/
8013             j = 0;
8014             while (isprint(b[i])) {
8015                 image_argv[j++] = b[i++];
8016                 if (j >= NAM$C_MAXRSS)
8017                    break;
8018             }
8019             while ((j > 0) && !isprint(image_argv[j-1]))
8020                 j--;
8021             image_argv[j] = 0;
8022
8023             /* It will need to be converted to VMS format and validated */
8024             if (tmpspec[0] != '\0') {
8025               char * iname;
8026
8027                /* Try to find the exact program requested to be run */
8028               /*---------------------------------------------------*/
8029               iname = do_rmsexpand
8030                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8031               if (iname != NULL) {
8032                 if (cando_by_name(S_IXUSR,0,image_name)) {
8033                   /* MCR prefix needed */
8034                   isdcl = 0;
8035                 }
8036                 else {
8037                    /* Try again with a null type */
8038                   /*----------------------------*/
8039                   iname = do_rmsexpand
8040                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8041                   if (iname != NULL) {
8042                     if (cando_by_name(S_IXUSR,0,image_name)) {
8043                       /* MCR prefix needed */
8044                       isdcl = 0;
8045                     }
8046                   }
8047                 }
8048
8049                  /* Did we find the image to run the script? */
8050                 /*------------------------------------------*/
8051                 if (isdcl) {
8052                   char *tchr;
8053
8054                    /* Assume DCL or foreign command exists */
8055                   /*--------------------------------------*/
8056                   tchr = strrchr(tmpspec, '/');
8057                   if (tchr != NULL) {
8058                     tchr++;
8059                   }
8060                   else {
8061                     tchr = tmpspec;
8062                   }
8063                   strcpy(image_name, tchr);
8064                 }
8065               }
8066             }
8067           }
8068         }
8069         fclose(fp);
8070       }
8071       if (check_img && isdcl) return RMS$_FNF;
8072
8073       if (cando_by_name(S_IXUSR,0,resspec)) {
8074         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8075         if (!isdcl) {
8076             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8077             if (image_name[0] != 0) {
8078                 strcat(vmscmd->dsc$a_pointer, image_name);
8079                 strcat(vmscmd->dsc$a_pointer, " ");
8080             }
8081         } else if (image_name[0] != 0) {
8082             strcpy(vmscmd->dsc$a_pointer, image_name);
8083             strcat(vmscmd->dsc$a_pointer, " ");
8084         } else {
8085             strcpy(vmscmd->dsc$a_pointer,"@");
8086         }
8087         if (suggest_quote) *suggest_quote = 1;
8088
8089         /* If there is an image name, use original command */
8090         if (image_name[0] == 0)
8091             strcat(vmscmd->dsc$a_pointer,resspec);
8092         else {
8093             rest = cmd;
8094             while (*rest && isspace(*rest)) rest++;
8095         }
8096
8097         if (image_argv[0] != 0) {
8098           strcat(vmscmd->dsc$a_pointer,image_argv);
8099           strcat(vmscmd->dsc$a_pointer, " ");
8100         }
8101         if (rest) {
8102            int rest_len;
8103            int vmscmd_len;
8104
8105            rest_len = strlen(rest);
8106            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8107            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8108               strcat(vmscmd->dsc$a_pointer,rest);
8109            else
8110              retsts = CLI$_BUFOVF;
8111         }
8112         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8113         Safefree(cmd);
8114         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8115       }
8116       else retsts = RMS$_PRV;
8117     }
8118   }
8119   /* It's either a DCL command or we couldn't find a suitable image */
8120   vmscmd->dsc$w_length = strlen(cmd);
8121 /*  if (cmd == PL_Cmd) {
8122       vmscmd->dsc$a_pointer = PL_Cmd;
8123       if (suggest_quote) *suggest_quote = 1;
8124   }
8125   else  */
8126       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8127
8128   Safefree(cmd);
8129
8130   /* check if it's a symbol (for quoting purposes) */
8131   if (suggest_quote && !*suggest_quote) {
8132     int iss;
8133     char equiv[LNM$C_NAMLENGTH];
8134     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8135     eqvdsc.dsc$a_pointer = equiv;
8136
8137     iss = lib$get_symbol(vmscmd,&eqvdsc);
8138     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8139   }
8140   if (!(retsts & 1)) {
8141     /* just hand off status values likely to be due to user error */
8142     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8143         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8144        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8145     else { _ckvmssts(retsts); }
8146   }
8147
8148   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8149
8150 }  /* end of setup_cmddsc() */
8151
8152
8153 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8154 bool
8155 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8156 {
8157   if (sp > mark) {
8158     if (vfork_called) {           /* this follows a vfork - act Unixish */
8159       vfork_called--;
8160       if (vfork_called < 0) {
8161         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8162         vfork_called = 0;
8163       }
8164       else return do_aexec(really,mark,sp);
8165     }
8166                                            /* no vfork - act VMSish */
8167     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8168
8169   }
8170
8171   return FALSE;
8172 }  /* end of vms_do_aexec() */
8173 /*}}}*/
8174
8175 /* {{{bool vms_do_exec(char *cmd) */
8176 bool
8177 Perl_vms_do_exec(pTHX_ const char *cmd)
8178 {
8179   struct dsc$descriptor_s *vmscmd;
8180
8181   if (vfork_called) {             /* this follows a vfork - act Unixish */
8182     vfork_called--;
8183     if (vfork_called < 0) {
8184       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8185       vfork_called = 0;
8186     }
8187     else return do_exec(cmd);
8188   }
8189
8190   {                               /* no vfork - act VMSish */
8191     unsigned long int retsts;
8192
8193     TAINT_ENV();
8194     TAINT_PROPER("exec");
8195     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8196       retsts = lib$do_command(vmscmd);
8197
8198     switch (retsts) {
8199       case RMS$_FNF: case RMS$_DNF:
8200         set_errno(ENOENT); break;
8201       case RMS$_DIR:
8202         set_errno(ENOTDIR); break;
8203       case RMS$_DEV:
8204         set_errno(ENODEV); break;
8205       case RMS$_PRV:
8206         set_errno(EACCES); break;
8207       case RMS$_SYN:
8208         set_errno(EINVAL); break;
8209       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8210         set_errno(E2BIG); break;
8211       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8212         _ckvmssts(retsts); /* fall through */
8213       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8214         set_errno(EVMSERR);
8215     }
8216     set_vaxc_errno(retsts);
8217     if (ckWARN(WARN_EXEC)) {
8218       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8219              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8220     }
8221     vms_execfree(vmscmd);
8222   }
8223
8224   return FALSE;
8225
8226 }  /* end of vms_do_exec() */
8227 /*}}}*/
8228
8229 unsigned long int Perl_do_spawn(pTHX_ const char *);
8230
8231 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8232 unsigned long int
8233 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8234 {
8235   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8236
8237   return SS$_ABORT;
8238 }  /* end of do_aspawn() */
8239 /*}}}*/
8240
8241 /* {{{unsigned long int do_spawn(char *cmd) */
8242 unsigned long int
8243 Perl_do_spawn(pTHX_ const char *cmd)
8244 {
8245   unsigned long int sts, substs;
8246
8247   TAINT_ENV();
8248   TAINT_PROPER("spawn");
8249   if (!cmd || !*cmd) {
8250     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8251     if (!(sts & 1)) {
8252       switch (sts) {
8253         case RMS$_FNF:  case RMS$_DNF:
8254           set_errno(ENOENT); break;
8255         case RMS$_DIR:
8256           set_errno(ENOTDIR); break;
8257         case RMS$_DEV:
8258           set_errno(ENODEV); break;
8259         case RMS$_PRV:
8260           set_errno(EACCES); break;
8261         case RMS$_SYN:
8262           set_errno(EINVAL); break;
8263         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8264           set_errno(E2BIG); break;
8265         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8266           _ckvmssts(sts); /* fall through */
8267         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8268           set_errno(EVMSERR);
8269       }
8270       set_vaxc_errno(sts);
8271       if (ckWARN(WARN_EXEC)) {
8272         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8273                     Strerror(errno));
8274       }
8275     }
8276     sts = substs;
8277   }
8278   else {
8279     PerlIO * fp;
8280     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8281     if (fp != NULL)
8282       my_pclose(fp);
8283   }
8284   return sts;
8285 }  /* end of do_spawn() */
8286 /*}}}*/
8287
8288
8289 static unsigned int *sockflags, sockflagsize;
8290
8291 /*
8292  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8293  * routines found in some versions of the CRTL can't deal with sockets.
8294  * We don't shim the other file open routines since a socket isn't
8295  * likely to be opened by a name.
8296  */
8297 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8298 FILE *my_fdopen(int fd, const char *mode)
8299 {
8300   FILE *fp = fdopen(fd, mode);
8301
8302   if (fp) {
8303     unsigned int fdoff = fd / sizeof(unsigned int);
8304     Stat_t sbuf; /* native stat; we don't need flex_stat */
8305     if (!sockflagsize || fdoff > sockflagsize) {
8306       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8307       else           Newx  (sockflags,fdoff+2,unsigned int);
8308       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8309       sockflagsize = fdoff + 2;
8310     }
8311     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8312       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8313   }
8314   return fp;
8315
8316 }
8317 /*}}}*/
8318
8319
8320 /*
8321  * Clear the corresponding bit when the (possibly) socket stream is closed.
8322  * There still a small hole: we miss an implicit close which might occur
8323  * via freopen().  >> Todo
8324  */
8325 /*{{{ int my_fclose(FILE *fp)*/
8326 int my_fclose(FILE *fp) {
8327   if (fp) {
8328     unsigned int fd = fileno(fp);
8329     unsigned int fdoff = fd / sizeof(unsigned int);
8330
8331     if (sockflagsize && fdoff <= sockflagsize)
8332       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8333   }
8334   return fclose(fp);
8335 }
8336 /*}}}*/
8337
8338
8339 /*
8340  * A simple fwrite replacement which outputs itmsz*nitm chars without
8341  * introducing record boundaries every itmsz chars.
8342  * We are using fputs, which depends on a terminating null.  We may
8343  * well be writing binary data, so we need to accommodate not only
8344  * data with nulls sprinkled in the middle but also data with no null
8345  * byte at the end.
8346  */
8347 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8348 int
8349 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8350 {
8351   register char *cp, *end, *cpd, *data;
8352   register unsigned int fd = fileno(dest);
8353   register unsigned int fdoff = fd / sizeof(unsigned int);
8354   int retval;
8355   int bufsize = itmsz * nitm + 1;
8356
8357   if (fdoff < sockflagsize &&
8358       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8359     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8360     return nitm;
8361   }
8362
8363   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8364   memcpy( data, src, itmsz*nitm );
8365   data[itmsz*nitm] = '\0';
8366
8367   end = data + itmsz * nitm;
8368   retval = (int) nitm; /* on success return # items written */
8369
8370   cpd = data;
8371   while (cpd <= end) {
8372     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8373     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8374     if (cp < end)
8375       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8376     cpd = cp + 1;
8377   }
8378
8379   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8380   return retval;
8381
8382 }  /* end of my_fwrite() */
8383 /*}}}*/
8384
8385 /*{{{ int my_flush(FILE *fp)*/
8386 int
8387 Perl_my_flush(pTHX_ FILE *fp)
8388 {
8389     int res;
8390     if ((res = fflush(fp)) == 0 && fp) {
8391 #ifdef VMS_DO_SOCKETS
8392         Stat_t s;
8393         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8394 #endif
8395             res = fsync(fileno(fp));
8396     }
8397 /*
8398  * If the flush succeeded but set end-of-file, we need to clear
8399  * the error because our caller may check ferror().  BTW, this
8400  * probably means we just flushed an empty file.
8401  */
8402     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8403
8404     return res;
8405 }
8406 /*}}}*/
8407
8408 /*
8409  * Here are replacements for the following Unix routines in the VMS environment:
8410  *      getpwuid    Get information for a particular UIC or UID
8411  *      getpwnam    Get information for a named user
8412  *      getpwent    Get information for each user in the rights database
8413  *      setpwent    Reset search to the start of the rights database
8414  *      endpwent    Finish searching for users in the rights database
8415  *
8416  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8417  * (defined in pwd.h), which contains the following fields:-
8418  *      struct passwd {
8419  *              char        *pw_name;    Username (in lower case)
8420  *              char        *pw_passwd;  Hashed password
8421  *              unsigned int pw_uid;     UIC
8422  *              unsigned int pw_gid;     UIC group  number
8423  *              char        *pw_unixdir; Default device/directory (VMS-style)
8424  *              char        *pw_gecos;   Owner name
8425  *              char        *pw_dir;     Default device/directory (Unix-style)
8426  *              char        *pw_shell;   Default CLI name (eg. DCL)
8427  *      };
8428  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8429  *
8430  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8431  * not the UIC member number (eg. what's returned by getuid()),
8432  * getpwuid() can accept either as input (if uid is specified, the caller's
8433  * UIC group is used), though it won't recognise gid=0.
8434  *
8435  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8436  * information about other users in your group or in other groups, respectively.
8437  * If the required privilege is not available, then these routines fill only
8438  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8439  * string).
8440  *
8441  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8442  */
8443
8444 /* sizes of various UAF record fields */
8445 #define UAI$S_USERNAME 12
8446 #define UAI$S_IDENT    31
8447 #define UAI$S_OWNER    31
8448 #define UAI$S_DEFDEV   31
8449 #define UAI$S_DEFDIR   63
8450 #define UAI$S_DEFCLI   31
8451 #define UAI$S_PWD       8
8452
8453 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8454                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8455                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8456
8457 static char __empty[]= "";
8458 static struct passwd __passwd_empty=
8459     {(char *) __empty, (char *) __empty, 0, 0,
8460      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8461 static int contxt= 0;
8462 static struct passwd __pwdcache;
8463 static char __pw_namecache[UAI$S_IDENT+1];
8464
8465 /*
8466  * This routine does most of the work extracting the user information.
8467  */
8468 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8469 {
8470     static struct {
8471         unsigned char length;
8472         char pw_gecos[UAI$S_OWNER+1];
8473     } owner;
8474     static union uicdef uic;
8475     static struct {
8476         unsigned char length;
8477         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8478     } defdev;
8479     static struct {
8480         unsigned char length;
8481         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8482     } defdir;
8483     static struct {
8484         unsigned char length;
8485         char pw_shell[UAI$S_DEFCLI+1];
8486     } defcli;
8487     static char pw_passwd[UAI$S_PWD+1];
8488
8489     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8490     struct dsc$descriptor_s name_desc;
8491     unsigned long int sts;
8492
8493     static struct itmlst_3 itmlst[]= {
8494         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8495         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8496         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8497         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8498         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8499         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8500         {0,                0,           NULL,    NULL}};
8501
8502     name_desc.dsc$w_length=  strlen(name);
8503     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8504     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8505     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8506
8507 /*  Note that sys$getuai returns many fields as counted strings. */
8508     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8509     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8510       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8511     }
8512     else { _ckvmssts(sts); }
8513     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8514
8515     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8516     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8517     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8518     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8519     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8520     owner.pw_gecos[lowner]=            '\0';
8521     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8522     defcli.pw_shell[ldefcli]=          '\0';
8523     if (valid_uic(uic)) {
8524         pwd->pw_uid= uic.uic$l_uic;
8525         pwd->pw_gid= uic.uic$v_group;
8526     }
8527     else
8528       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8529     pwd->pw_passwd=  pw_passwd;
8530     pwd->pw_gecos=   owner.pw_gecos;
8531     pwd->pw_dir=     defdev.pw_dir;
8532     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8533     pwd->pw_shell=   defcli.pw_shell;
8534     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8535         int ldir;
8536         ldir= strlen(pwd->pw_unixdir) - 1;
8537         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8538     }
8539     else
8540         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8541     if (!decc_efs_case_preserve)
8542         __mystrtolower(pwd->pw_unixdir);
8543     return 1;
8544 }
8545
8546 /*
8547  * Get information for a named user.
8548 */
8549 /*{{{struct passwd *getpwnam(char *name)*/
8550 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8551 {
8552     struct dsc$descriptor_s name_desc;
8553     union uicdef uic;
8554     unsigned long int status, sts;
8555
8556     __pwdcache = __passwd_empty;
8557     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8558       /* We still may be able to determine pw_uid and pw_gid */
8559       name_desc.dsc$w_length=  strlen(name);
8560       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8561       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8562       name_desc.dsc$a_pointer= (char *) name;
8563       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8564         __pwdcache.pw_uid= uic.uic$l_uic;
8565         __pwdcache.pw_gid= uic.uic$v_group;
8566       }
8567       else {
8568         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8569           set_vaxc_errno(sts);
8570           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8571           return NULL;
8572         }
8573         else { _ckvmssts(sts); }
8574       }
8575     }
8576     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8577     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8578     __pwdcache.pw_name= __pw_namecache;
8579     return &__pwdcache;
8580 }  /* end of my_getpwnam() */
8581 /*}}}*/
8582
8583 /*
8584  * Get information for a particular UIC or UID.
8585  * Called by my_getpwent with uid=-1 to list all users.
8586 */
8587 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8588 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8589 {
8590     const $DESCRIPTOR(name_desc,__pw_namecache);
8591     unsigned short lname;
8592     union uicdef uic;
8593     unsigned long int status;
8594
8595     if (uid == (unsigned int) -1) {
8596       do {
8597         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8598         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8599           set_vaxc_errno(status);
8600           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8601           my_endpwent();
8602           return NULL;
8603         }
8604         else { _ckvmssts(status); }
8605       } while (!valid_uic (uic));
8606     }
8607     else {
8608       uic.uic$l_uic= uid;
8609       if (!uic.uic$v_group)
8610         uic.uic$v_group= PerlProc_getgid();
8611       if (valid_uic(uic))
8612         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8613       else status = SS$_IVIDENT;
8614       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8615           status == RMS$_PRV) {
8616         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8617         return NULL;
8618       }
8619       else { _ckvmssts(status); }
8620     }
8621     __pw_namecache[lname]= '\0';
8622     __mystrtolower(__pw_namecache);
8623
8624     __pwdcache = __passwd_empty;
8625     __pwdcache.pw_name = __pw_namecache;
8626
8627 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8628     The identifier's value is usually the UIC, but it doesn't have to be,
8629     so if we can, we let fillpasswd update this. */
8630     __pwdcache.pw_uid =  uic.uic$l_uic;
8631     __pwdcache.pw_gid =  uic.uic$v_group;
8632
8633     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8634     return &__pwdcache;
8635
8636 }  /* end of my_getpwuid() */
8637 /*}}}*/
8638
8639 /*
8640  * Get information for next user.
8641 */
8642 /*{{{struct passwd *my_getpwent()*/
8643 struct passwd *Perl_my_getpwent(pTHX)
8644 {
8645     return (my_getpwuid((unsigned int) -1));
8646 }
8647 /*}}}*/
8648
8649 /*
8650  * Finish searching rights database for users.
8651 */
8652 /*{{{void my_endpwent()*/
8653 void Perl_my_endpwent(pTHX)
8654 {
8655     if (contxt) {
8656       _ckvmssts(sys$finish_rdb(&contxt));
8657       contxt= 0;
8658     }
8659 }
8660 /*}}}*/
8661
8662 #ifdef HOMEGROWN_POSIX_SIGNALS
8663   /* Signal handling routines, pulled into the core from POSIX.xs.
8664    *
8665    * We need these for threads, so they've been rolled into the core,
8666    * rather than left in POSIX.xs.
8667    *
8668    * (DRS, Oct 23, 1997)
8669    */
8670
8671   /* sigset_t is atomic under VMS, so these routines are easy */
8672 /*{{{int my_sigemptyset(sigset_t *) */
8673 int my_sigemptyset(sigset_t *set) {
8674     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8675     *set = 0; return 0;
8676 }
8677 /*}}}*/
8678
8679
8680 /*{{{int my_sigfillset(sigset_t *)*/
8681 int my_sigfillset(sigset_t *set) {
8682     int i;
8683     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8684     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8685     return 0;
8686 }
8687 /*}}}*/
8688
8689
8690 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8691 int my_sigaddset(sigset_t *set, int sig) {
8692     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8693     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8694     *set |= (1 << (sig - 1));
8695     return 0;
8696 }
8697 /*}}}*/
8698
8699
8700 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8701 int my_sigdelset(sigset_t *set, int sig) {
8702     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8703     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8704     *set &= ~(1 << (sig - 1));
8705     return 0;
8706 }
8707 /*}}}*/
8708
8709
8710 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8711 int my_sigismember(sigset_t *set, int sig) {
8712     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8713     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8714     return *set & (1 << (sig - 1));
8715 }
8716 /*}}}*/
8717
8718
8719 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8720 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8721     sigset_t tempmask;
8722
8723     /* If set and oset are both null, then things are badly wrong. Bail out. */
8724     if ((oset == NULL) && (set == NULL)) {
8725       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8726       return -1;
8727     }
8728
8729     /* If set's null, then we're just handling a fetch. */
8730     if (set == NULL) {
8731         tempmask = sigblock(0);
8732     }
8733     else {
8734       switch (how) {
8735       case SIG_SETMASK:
8736         tempmask = sigsetmask(*set);
8737         break;
8738       case SIG_BLOCK:
8739         tempmask = sigblock(*set);
8740         break;
8741       case SIG_UNBLOCK:
8742         tempmask = sigblock(0);
8743         sigsetmask(*oset & ~tempmask);
8744         break;
8745       default:
8746         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8747         return -1;
8748       }
8749     }
8750
8751     /* Did they pass us an oset? If so, stick our holding mask into it */
8752     if (oset)
8753       *oset = tempmask;
8754
8755     return 0;
8756 }
8757 /*}}}*/
8758 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8759
8760
8761 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8762  * my_utime(), and flex_stat(), all of which operate on UTC unless
8763  * VMSISH_TIMES is true.
8764  */
8765 /* method used to handle UTC conversions:
8766  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8767  */
8768 static int gmtime_emulation_type;
8769 /* number of secs to add to UTC POSIX-style time to get local time */
8770 static long int utc_offset_secs;
8771
8772 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8773  * in vmsish.h.  #undef them here so we can call the CRTL routines
8774  * directly.
8775  */
8776 #undef gmtime
8777 #undef localtime
8778 #undef time
8779
8780
8781 /*
8782  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8783  * qualifier with the extern prefix pragma.  This provisional
8784  * hack circumvents this prefix pragma problem in previous
8785  * precompilers.
8786  */
8787 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8788 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8789 #    pragma __extern_prefix save
8790 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8791 #    define gmtime decc$__utctz_gmtime
8792 #    define localtime decc$__utctz_localtime
8793 #    define time decc$__utc_time
8794 #    pragma __extern_prefix restore
8795
8796      struct tm *gmtime(), *localtime();
8797
8798 #  endif
8799 #endif
8800
8801
8802 static time_t toutc_dst(time_t loc) {
8803   struct tm *rsltmp;
8804
8805   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8806   loc -= utc_offset_secs;
8807   if (rsltmp->tm_isdst) loc -= 3600;
8808   return loc;
8809 }
8810 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8811        ((gmtime_emulation_type || my_time(NULL)), \
8812        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8813        ((secs) - utc_offset_secs))))
8814
8815 static time_t toloc_dst(time_t utc) {
8816   struct tm *rsltmp;
8817
8818   utc += utc_offset_secs;
8819   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8820   if (rsltmp->tm_isdst) utc += 3600;
8821   return utc;
8822 }
8823 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8824        ((gmtime_emulation_type || my_time(NULL)), \
8825        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8826        ((secs) + utc_offset_secs))))
8827
8828 #ifndef RTL_USES_UTC
8829 /*
8830
8831     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8832         DST starts on 1st sun of april      at 02:00  std time
8833             ends on last sun of october     at 02:00  dst time
8834     see the UCX management command reference, SET CONFIG TIMEZONE
8835     for formatting info.
8836
8837     No, it's not as general as it should be, but then again, NOTHING
8838     will handle UK times in a sensible way.
8839 */
8840
8841
8842 /*
8843     parse the DST start/end info:
8844     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8845 */
8846
8847 static char *
8848 tz_parse_startend(char *s, struct tm *w, int *past)
8849 {
8850     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8851     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8852     time_t g;
8853
8854     if (!s)    return 0;
8855     if (!w) return 0;
8856     if (!past) return 0;
8857
8858     ly = 0;
8859     if (w->tm_year % 4        == 0) ly = 1;
8860     if (w->tm_year % 100      == 0) ly = 0;
8861     if (w->tm_year+1900 % 400 == 0) ly = 1;
8862     if (ly) dinm[1]++;
8863
8864     dozjd = isdigit(*s);
8865     if (*s == 'J' || *s == 'j' || dozjd) {
8866         if (!dozjd && !isdigit(*++s)) return 0;
8867         d = *s++ - '0';
8868         if (isdigit(*s)) {
8869             d = d*10 + *s++ - '0';
8870             if (isdigit(*s)) {
8871                 d = d*10 + *s++ - '0';
8872             }
8873         }
8874         if (d == 0) return 0;
8875         if (d > 366) return 0;
8876         d--;
8877         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8878         g = d * 86400;
8879         dozjd = 1;
8880     } else if (*s == 'M' || *s == 'm') {
8881         if (!isdigit(*++s)) return 0;
8882         m = *s++ - '0';
8883         if (isdigit(*s)) m = 10*m + *s++ - '0';
8884         if (*s != '.') return 0;
8885         if (!isdigit(*++s)) return 0;
8886         n = *s++ - '0';
8887         if (n < 1 || n > 5) return 0;
8888         if (*s != '.') return 0;
8889         if (!isdigit(*++s)) return 0;
8890         d = *s++ - '0';
8891         if (d > 6) return 0;
8892     }
8893
8894     if (*s == '/') {
8895         if (!isdigit(*++s)) return 0;
8896         hour = *s++ - '0';
8897         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8898         if (*s == ':') {
8899             if (!isdigit(*++s)) return 0;
8900             min = *s++ - '0';
8901             if (isdigit(*s)) min = 10*min + *s++ - '0';
8902             if (*s == ':') {
8903                 if (!isdigit(*++s)) return 0;
8904                 sec = *s++ - '0';
8905                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8906             }
8907         }
8908     } else {
8909         hour = 2;
8910         min = 0;
8911         sec = 0;
8912     }
8913
8914     if (dozjd) {
8915         if (w->tm_yday < d) goto before;
8916         if (w->tm_yday > d) goto after;
8917     } else {
8918         if (w->tm_mon+1 < m) goto before;
8919         if (w->tm_mon+1 > m) goto after;
8920
8921         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8922         k = d - j; /* mday of first d */
8923         if (k <= 0) k += 7;
8924         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8925         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8926         if (w->tm_mday < k) goto before;
8927         if (w->tm_mday > k) goto after;
8928     }
8929
8930     if (w->tm_hour < hour) goto before;
8931     if (w->tm_hour > hour) goto after;
8932     if (w->tm_min  < min)  goto before;
8933     if (w->tm_min  > min)  goto after;
8934     if (w->tm_sec  < sec)  goto before;
8935     goto after;
8936
8937 before:
8938     *past = 0;
8939     return s;
8940 after:
8941     *past = 1;
8942     return s;
8943 }
8944
8945
8946
8947
8948 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8949
8950 static char *
8951 tz_parse_offset(char *s, int *offset)
8952 {
8953     int hour = 0, min = 0, sec = 0;
8954     int neg = 0;
8955     if (!s) return 0;
8956     if (!offset) return 0;
8957
8958     if (*s == '-') {neg++; s++;}
8959     if (*s == '+') s++;
8960     if (!isdigit(*s)) return 0;
8961     hour = *s++ - '0';
8962     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8963     if (hour > 24) return 0;
8964     if (*s == ':') {
8965         if (!isdigit(*++s)) return 0;
8966         min = *s++ - '0';
8967         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8968         if (min > 59) return 0;
8969         if (*s == ':') {
8970             if (!isdigit(*++s)) return 0;
8971             sec = *s++ - '0';
8972             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8973             if (sec > 59) return 0;
8974         }
8975     }
8976
8977     *offset = (hour*60+min)*60 + sec;
8978     if (neg) *offset = -*offset;
8979     return s;
8980 }
8981
8982 /*
8983     input time is w, whatever type of time the CRTL localtime() uses.
8984     sets dst, the zone, and the gmtoff (seconds)
8985
8986     caches the value of TZ and UCX$TZ env variables; note that
8987     my_setenv looks for these and sets a flag if they're changed
8988     for efficiency.
8989
8990     We have to watch out for the "australian" case (dst starts in
8991     october, ends in april)...flagged by "reverse" and checked by
8992     scanning through the months of the previous year.
8993
8994 */
8995
8996 static int
8997 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8998 {
8999     time_t when;
9000     struct tm *w2;
9001     char *s,*s2;
9002     char *dstzone, *tz, *s_start, *s_end;
9003     int std_off, dst_off, isdst;
9004     int y, dststart, dstend;
9005     static char envtz[1025];  /* longer than any logical, symbol, ... */
9006     static char ucxtz[1025];
9007     static char reversed = 0;
9008
9009     if (!w) return 0;
9010
9011     if (tz_updated) {
9012         tz_updated = 0;
9013         reversed = -1;  /* flag need to check  */
9014         envtz[0] = ucxtz[0] = '\0';
9015         tz = my_getenv("TZ",0);
9016         if (tz) strcpy(envtz, tz);
9017         tz = my_getenv("UCX$TZ",0);
9018         if (tz) strcpy(ucxtz, tz);
9019         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9020     }
9021     tz = envtz;
9022     if (!*tz) tz = ucxtz;
9023
9024     s = tz;
9025     while (isalpha(*s)) s++;
9026     s = tz_parse_offset(s, &std_off);
9027     if (!s) return 0;
9028     if (!*s) {                  /* no DST, hurray we're done! */
9029         isdst = 0;
9030         goto done;
9031     }
9032
9033     dstzone = s;
9034     while (isalpha(*s)) s++;
9035     s2 = tz_parse_offset(s, &dst_off);
9036     if (s2) {
9037         s = s2;
9038     } else {
9039         dst_off = std_off - 3600;
9040     }
9041
9042     if (!*s) {      /* default dst start/end?? */
9043         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9044             s = strchr(ucxtz,',');
9045         }
9046         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9047     }
9048     if (*s != ',') return 0;
9049
9050     when = *w;
9051     when = _toutc(when);      /* convert to utc */
9052     when = when - std_off;    /* convert to pseudolocal time*/
9053
9054     w2 = localtime(&when);
9055     y = w2->tm_year;
9056     s_start = s+1;
9057     s = tz_parse_startend(s_start,w2,&dststart);
9058     if (!s) return 0;
9059     if (*s != ',') return 0;
9060
9061     when = *w;
9062     when = _toutc(when);      /* convert to utc */
9063     when = when - dst_off;    /* convert to pseudolocal time*/
9064     w2 = localtime(&when);
9065     if (w2->tm_year != y) {   /* spans a year, just check one time */
9066         when += dst_off - std_off;
9067         w2 = localtime(&when);
9068     }
9069     s_end = s+1;
9070     s = tz_parse_startend(s_end,w2,&dstend);
9071     if (!s) return 0;
9072
9073     if (reversed == -1) {  /* need to check if start later than end */
9074         int j, ds, de;
9075
9076         when = *w;
9077         if (when < 2*365*86400) {
9078             when += 2*365*86400;
9079         } else {
9080             when -= 365*86400;
9081         }
9082         w2 =localtime(&when);
9083         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9084
9085         for (j = 0; j < 12; j++) {
9086             w2 =localtime(&when);
9087             tz_parse_startend(s_start,w2,&ds);
9088             tz_parse_startend(s_end,w2,&de);
9089             if (ds != de) break;
9090             when += 30*86400;
9091         }
9092         reversed = 0;
9093         if (de && !ds) reversed = 1;
9094     }
9095
9096     isdst = dststart && !dstend;
9097     if (reversed) isdst = dststart  || !dstend;
9098
9099 done:
9100     if (dst)    *dst = isdst;
9101     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9102     if (isdst)  tz = dstzone;
9103     if (zone) {
9104         while(isalpha(*tz))  *zone++ = *tz++;
9105         *zone = '\0';
9106     }
9107     return 1;
9108 }
9109
9110 #endif /* !RTL_USES_UTC */
9111
9112 /* my_time(), my_localtime(), my_gmtime()
9113  * By default traffic in UTC time values, using CRTL gmtime() or
9114  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9115  * Note: We need to use these functions even when the CRTL has working
9116  * UTC support, since they also handle C<use vmsish qw(times);>
9117  *
9118  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9119  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9120  */
9121
9122 /*{{{time_t my_time(time_t *timep)*/
9123 time_t Perl_my_time(pTHX_ time_t *timep)
9124 {
9125   time_t when;
9126   struct tm *tm_p;
9127
9128   if (gmtime_emulation_type == 0) {
9129     int dstnow;
9130     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9131                               /* results of calls to gmtime() and localtime() */
9132                               /* for same &base */
9133
9134     gmtime_emulation_type++;
9135     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9136       char off[LNM$C_NAMLENGTH+1];;
9137
9138       gmtime_emulation_type++;
9139       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9140         gmtime_emulation_type++;
9141         utc_offset_secs = 0;
9142         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9143       }
9144       else { utc_offset_secs = atol(off); }
9145     }
9146     else { /* We've got a working gmtime() */
9147       struct tm gmt, local;
9148
9149       gmt = *tm_p;
9150       tm_p = localtime(&base);
9151       local = *tm_p;
9152       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9153       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9154       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9155       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9156     }
9157   }
9158
9159   when = time(NULL);
9160 # ifdef VMSISH_TIME
9161 # ifdef RTL_USES_UTC
9162   if (VMSISH_TIME) when = _toloc(when);
9163 # else
9164   if (!VMSISH_TIME) when = _toutc(when);
9165 # endif
9166 # endif
9167   if (timep != NULL) *timep = when;
9168   return when;
9169
9170 }  /* end of my_time() */
9171 /*}}}*/
9172
9173
9174 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9175 struct tm *
9176 Perl_my_gmtime(pTHX_ const time_t *timep)
9177 {
9178   char *p;
9179   time_t when;
9180   struct tm *rsltmp;
9181
9182   if (timep == NULL) {
9183     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9184     return NULL;
9185   }
9186   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9187
9188   when = *timep;
9189 # ifdef VMSISH_TIME
9190   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9191 #  endif
9192 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9193   return gmtime(&when);
9194 # else
9195   /* CRTL localtime() wants local time as input, so does no tz correction */
9196   rsltmp = localtime(&when);
9197   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9198   return rsltmp;
9199 #endif
9200 }  /* end of my_gmtime() */
9201 /*}}}*/
9202
9203
9204 /*{{{struct tm *my_localtime(const time_t *timep)*/
9205 struct tm *
9206 Perl_my_localtime(pTHX_ const time_t *timep)
9207 {
9208   time_t when, whenutc;
9209   struct tm *rsltmp;
9210   int dst, offset;
9211
9212   if (timep == NULL) {
9213     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9214     return NULL;
9215   }
9216   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9217   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9218
9219   when = *timep;
9220 # ifdef RTL_USES_UTC
9221 # ifdef VMSISH_TIME
9222   if (VMSISH_TIME) when = _toutc(when);
9223 # endif
9224   /* CRTL localtime() wants UTC as input, does tz correction itself */
9225   return localtime(&when);
9226
9227 # else /* !RTL_USES_UTC */
9228   whenutc = when;
9229 # ifdef VMSISH_TIME
9230   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9231   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9232 # endif
9233   dst = -1;
9234 #ifndef RTL_USES_UTC
9235   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9236       when = whenutc - offset;                   /* pseudolocal time*/
9237   }
9238 # endif
9239   /* CRTL localtime() wants local time as input, so does no tz correction */
9240   rsltmp = localtime(&when);
9241   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9242   return rsltmp;
9243 # endif
9244
9245 } /*  end of my_localtime() */
9246 /*}}}*/
9247
9248 /* Reset definitions for later calls */
9249 #define gmtime(t)    my_gmtime(t)
9250 #define localtime(t) my_localtime(t)
9251 #define time(t)      my_time(t)
9252
9253
9254 /* my_utime - update modification time of a file
9255  * calling sequence is identical to POSIX utime(), but under
9256  * VMS only the modification time is changed; ODS-2 does not
9257  * maintain access times.  Restrictions differ from the POSIX
9258  * definition in that the time can be changed as long as the
9259  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9260  * no separate checks are made to insure that the caller is the
9261  * owner of the file or has special privs enabled.
9262  * Code here is based on Joe Meadows' FILE utility.
9263  */
9264
9265 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9266  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9267  * in 100 ns intervals.
9268  */
9269 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9270
9271 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9272 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9273 {
9274   register int i;
9275   int sts;
9276   long int bintime[2], len = 2, lowbit, unixtime,
9277            secscale = 10000000; /* seconds --> 100 ns intervals */
9278   unsigned long int chan, iosb[2], retsts;
9279   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9280   struct FAB myfab = cc$rms_fab;
9281   struct NAM mynam = cc$rms_nam;
9282 #if defined (__DECC) && defined (__VAX)
9283   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9284    * at least through VMS V6.1, which causes a type-conversion warning.
9285    */
9286 #  pragma message save
9287 #  pragma message disable cvtdiftypes
9288 #endif
9289   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9290   struct fibdef myfib;
9291 #if defined (__DECC) && defined (__VAX)
9292   /* This should be right after the declaration of myatr, but due
9293    * to a bug in VAX DEC C, this takes effect a statement early.
9294    */
9295 #  pragma message restore
9296 #endif
9297   /* cast ok for read only parameter */
9298   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9299                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9300                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9301
9302   if (file == NULL || *file == '\0') {
9303     set_errno(ENOENT);
9304     set_vaxc_errno(LIB$_INVARG);
9305     return -1;
9306   }
9307   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9308
9309   if (utimes != NULL) {
9310     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9311      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9312      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9313      * as input, we force the sign bit to be clear by shifting unixtime right
9314      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9315      */
9316     lowbit = (utimes->modtime & 1) ? secscale : 0;
9317     unixtime = (long int) utimes->modtime;
9318 #   ifdef VMSISH_TIME
9319     /* If input was UTC; convert to local for sys svc */
9320     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9321 #   endif
9322     unixtime >>= 1;  secscale <<= 1;
9323     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9324     if (!(retsts & 1)) {
9325       set_errno(EVMSERR);
9326       set_vaxc_errno(retsts);
9327       return -1;
9328     }
9329     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9330     if (!(retsts & 1)) {
9331       set_errno(EVMSERR);
9332       set_vaxc_errno(retsts);
9333       return -1;
9334     }
9335   }
9336   else {
9337     /* Just get the current time in VMS format directly */
9338     retsts = sys$gettim(bintime);
9339     if (!(retsts & 1)) {
9340       set_errno(EVMSERR);
9341       set_vaxc_errno(retsts);
9342       return -1;
9343     }
9344   }
9345
9346   myfab.fab$l_fna = vmsspec;
9347   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9348   myfab.fab$l_nam = &mynam;
9349   mynam.nam$l_esa = esa;
9350   mynam.nam$b_ess = (unsigned char) sizeof esa;
9351   mynam.nam$l_rsa = rsa;
9352   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9353   if (decc_efs_case_preserve)
9354       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9355
9356   /* Look for the file to be affected, letting RMS parse the file
9357    * specification for us as well.  I have set errno using only
9358    * values documented in the utime() man page for VMS POSIX.
9359    */
9360   retsts = sys$parse(&myfab,0,0);
9361   if (!(retsts & 1)) {
9362     set_vaxc_errno(retsts);
9363     if      (retsts == RMS$_PRV) set_errno(EACCES);
9364     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9365     else                         set_errno(EVMSERR);
9366     return -1;
9367   }
9368   retsts = sys$search(&myfab,0,0);
9369   if (!(retsts & 1)) {
9370     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9371     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9372     set_vaxc_errno(retsts);
9373     if      (retsts == RMS$_PRV) set_errno(EACCES);
9374     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9375     else                         set_errno(EVMSERR);
9376     return -1;
9377   }
9378
9379   devdsc.dsc$w_length = mynam.nam$b_dev;
9380   /* cast ok for read only parameter */
9381   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9382
9383   retsts = sys$assign(&devdsc,&chan,0,0);
9384   if (!(retsts & 1)) {
9385     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9386     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9387     set_vaxc_errno(retsts);
9388     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9389     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9390     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9391     else                               set_errno(EVMSERR);
9392     return -1;
9393   }
9394
9395   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9396   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9397
9398   memset((void *) &myfib, 0, sizeof myfib);
9399 #if defined(__DECC) || defined(__DECCXX)
9400   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9401   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9402   /* This prevents the revision time of the file being reset to the current
9403    * time as a result of our IO$_MODIFY $QIO. */
9404   myfib.fib$l_acctl = FIB$M_NORECORD;
9405 #else
9406   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9407   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9408   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9409 #endif
9410   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9411   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9412   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9413   _ckvmssts(sys$dassgn(chan));
9414   if (retsts & 1) retsts = iosb[0];
9415   if (!(retsts & 1)) {
9416     set_vaxc_errno(retsts);
9417     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9418     else                      set_errno(EVMSERR);
9419     return -1;
9420   }
9421
9422   return 0;
9423 }  /* end of my_utime() */
9424 /*}}}*/
9425
9426 /*
9427  * flex_stat, flex_lstat, flex_fstat
9428  * basic stat, but gets it right when asked to stat
9429  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9430  */
9431
9432 #ifndef _USE_STD_STAT
9433 /* encode_dev packs a VMS device name string into an integer to allow
9434  * simple comparisons. This can be used, for example, to check whether two
9435  * files are located on the same device, by comparing their encoded device
9436  * names. Even a string comparison would not do, because stat() reuses the
9437  * device name buffer for each call; so without encode_dev, it would be
9438  * necessary to save the buffer and use strcmp (this would mean a number of
9439  * changes to the standard Perl code, to say nothing of what a Perl script
9440  * would have to do.
9441  *
9442  * The device lock id, if it exists, should be unique (unless perhaps compared
9443  * with lock ids transferred from other nodes). We have a lock id if the disk is
9444  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9445  * device names. Thus we use the lock id in preference, and only if that isn't
9446  * available, do we try to pack the device name into an integer (flagged by
9447  * the sign bit (LOCKID_MASK) being set).
9448  *
9449  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9450  * name and its encoded form, but it seems very unlikely that we will find
9451  * two files on different disks that share the same encoded device names,
9452  * and even more remote that they will share the same file id (if the test
9453  * is to check for the same file).
9454  *
9455  * A better method might be to use sys$device_scan on the first call, and to
9456  * search for the device, returning an index into the cached array.
9457  * The number returned would be more intelligable.
9458  * This is probably not worth it, and anyway would take quite a bit longer
9459  * on the first call.
9460  */
9461 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9462 static mydev_t encode_dev (pTHX_ const char *dev)
9463 {
9464   int i;
9465   unsigned long int f;
9466   mydev_t enc;
9467   char c;
9468   const char *q;
9469
9470   if (!dev || !dev[0]) return 0;
9471
9472 #if LOCKID_MASK
9473   {
9474     struct dsc$descriptor_s dev_desc;
9475     unsigned long int status, lockid, item = DVI$_LOCKID;
9476
9477     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9478        can try that first. */
9479     dev_desc.dsc$w_length =  strlen (dev);
9480     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9481     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9482     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9483     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9484     if (lockid) return (lockid & ~LOCKID_MASK);
9485   }
9486 #endif
9487
9488   /* Otherwise we try to encode the device name */
9489   enc = 0;
9490   f = 1;
9491   i = 0;
9492   for (q = dev + strlen(dev); q--; q >= dev) {
9493     if (isdigit (*q))
9494       c= (*q) - '0';
9495     else if (isalpha (toupper (*q)))
9496       c= toupper (*q) - 'A' + (char)10;
9497     else
9498       continue; /* Skip '$'s */
9499     i++;
9500     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9501     if (i>1) f *= 36;
9502     enc += f * (unsigned long int) c;
9503   }
9504   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9505
9506 }  /* end of encode_dev() */
9507 #endif
9508
9509 static char namecache[NAM$C_MAXRSS+1];
9510
9511 static int
9512 is_null_device(name)
9513     const char *name;
9514 {
9515   if (decc_bug_devnull != 0) {
9516     if (strncmp("/dev/null", name, 9) == 0)
9517       return 1;
9518   }
9519     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9520        The underscore prefix, controller letter, and unit number are
9521        independently optional; for our purposes, the colon punctuation
9522        is not.  The colon can be trailed by optional directory and/or
9523        filename, but two consecutive colons indicates a nodename rather
9524        than a device.  [pr]  */
9525   if (*name == '_') ++name;
9526   if (tolower(*name++) != 'n') return 0;
9527   if (tolower(*name++) != 'l') return 0;
9528   if (tolower(*name) == 'a') ++name;
9529   if (*name == '0') ++name;
9530   return (*name++ == ':') && (*name != ':');
9531 }
9532
9533 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9534 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9535  * subset of the applicable information.
9536  */
9537 bool
9538 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9539 {
9540   char fname_phdev[NAM$C_MAXRSS+1];
9541 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9542   /* Namecache not workable with symbolic links, as symbolic links do
9543    *  not have extensions and directories do in VMS mode.  So in order
9544    *  to test this, the did and ino_t must be used.
9545    *
9546    * Fix-me - Hide the information in the new stat structure
9547    *          Get rid of the namecache.
9548    */
9549   if (decc_posix_compliant_pathnames == 0)
9550 #endif
9551       if (statbufp == &PL_statcache)
9552           return cando_by_name(bit,effective,namecache);
9553   {
9554     char fname[NAM$C_MAXRSS+1];
9555     unsigned long int retsts;
9556     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9557                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9558
9559     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9560        device name on successive calls */
9561     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9562     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9563     namdsc.dsc$a_pointer = fname;
9564     namdsc.dsc$w_length = sizeof fname - 1;
9565
9566     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9567                              &namdsc,&namdsc.dsc$w_length,0,0);
9568     if (retsts & 1) {
9569       fname[namdsc.dsc$w_length] = '\0';
9570 /*
9571  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9572  * but if someone has redefined that logical, Perl gets very lost.  Since
9573  * we have the physical device name from the stat buffer, just paste it on.
9574  */
9575       strcpy( fname_phdev, statbufp->st_devnam );
9576       strcat( fname_phdev, strrchr(fname, ':') );
9577
9578       return cando_by_name(bit,effective,fname_phdev);
9579     }
9580     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9581       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9582       return FALSE;
9583     }
9584     _ckvmssts(retsts);
9585     return FALSE;  /* Should never get to here */
9586   }
9587 }  /* end of cando() */
9588 /*}}}*/
9589
9590
9591 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9592 I32
9593 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9594 {
9595   static char usrname[L_cuserid];
9596   static struct dsc$descriptor_s usrdsc =
9597          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9598   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9599   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9600   unsigned short int retlen, trnlnm_iter_count;
9601   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9602   union prvdef curprv;
9603   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9604          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9605   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9606          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9607          {0,0,0,0}};
9608   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9609          {0,0,0,0}};
9610   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9611
9612   if (!fname || !*fname) return FALSE;
9613   /* Make sure we expand logical names, since sys$check_access doesn't */
9614   if (!strpbrk(fname,"/]>:")) {
9615     strcpy(fileified,fname);
9616     trnlnm_iter_count = 0;
9617     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9618         trnlnm_iter_count++;
9619         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9620     }
9621     fname = fileified;
9622   }
9623   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9624   retlen = namdsc.dsc$w_length = strlen(vmsname);
9625   namdsc.dsc$a_pointer = vmsname;
9626   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9627       vmsname[retlen-1] == ':') {
9628     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9629     namdsc.dsc$w_length = strlen(fileified);
9630     namdsc.dsc$a_pointer = fileified;
9631   }
9632
9633   switch (bit) {
9634     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9635       access = ARM$M_EXECUTE; break;
9636     case S_IRUSR: case S_IRGRP: case S_IROTH:
9637       access = ARM$M_READ; break;
9638     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9639       access = ARM$M_WRITE; break;
9640     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9641       access = ARM$M_DELETE; break;
9642     default:
9643       return FALSE;
9644   }
9645
9646   /* Before we call $check_access, create a user profile with the current
9647    * process privs since otherwise it just uses the default privs from the
9648    * UAF and might give false positives or negatives.  This only works on
9649    * VMS versions v6.0 and later since that's when sys$create_user_profile
9650    * became available.
9651    */
9652
9653   /* get current process privs and username */
9654   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9655   _ckvmssts(iosb[0]);
9656
9657 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9658
9659   /* find out the space required for the profile */
9660   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9661                                     &usrprodsc.dsc$w_length,0));
9662
9663   /* allocate space for the profile and get it filled in */
9664   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9665   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9666                                     &usrprodsc.dsc$w_length,0));
9667
9668   /* use the profile to check access to the file; free profile & analyze results */
9669   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9670   Safefree(usrprodsc.dsc$a_pointer);
9671   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9672
9673 #else
9674
9675   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9676
9677 #endif
9678
9679   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9680       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9681       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9682     set_vaxc_errno(retsts);
9683     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9684     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9685     else set_errno(ENOENT);
9686     return FALSE;
9687   }
9688   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9689     return TRUE;
9690   }
9691   _ckvmssts(retsts);
9692
9693   return FALSE;  /* Should never get here */
9694
9695 }  /* end of cando_by_name() */
9696 /*}}}*/
9697
9698
9699 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9700 int
9701 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9702 {
9703   if (!fstat(fd,(stat_t *) statbufp)) {
9704     if (statbufp == (Stat_t *) &PL_statcache) {
9705     char *cptr;
9706
9707         /* Save name for cando by name in VMS format */
9708         cptr = getname(fd, namecache, 1);
9709
9710         /* This should not happen, but just in case */
9711         if (cptr == NULL)
9712            namecache[0] = '\0';
9713     }
9714
9715     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
9716 #ifndef _USE_STD_STAT
9717     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9718     statbufp->st_devnam[63] = 0;
9719     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9720 #else
9721     /* todo:
9722      * The device is only encoded so that Perl_cando can use it to
9723      * look up ACLS.  So rmsexpand it to the 255 character version
9724      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9725      * for long filenames and symbolic links first.  This also seems
9726      * to remove the need for a namecache that could be stale.
9727      */
9728 #endif
9729
9730 #   ifdef RTL_USES_UTC
9731 #   ifdef VMSISH_TIME
9732     if (VMSISH_TIME) {
9733       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9734       statbufp->st_atime = _toloc(statbufp->st_atime);
9735       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9736     }
9737 #   endif
9738 #   else
9739 #   ifdef VMSISH_TIME
9740     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9741 #   else
9742     if (1) {
9743 #   endif
9744       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9745       statbufp->st_atime = _toutc(statbufp->st_atime);
9746       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9747     }
9748 #endif
9749     return 0;
9750   }
9751   return -1;
9752
9753 }  /* end of flex_fstat() */
9754 /*}}}*/
9755
9756 #if !defined(__VAX) && __CRTL_VER >= 80200000
9757 #ifdef lstat
9758 #undef lstat
9759 #endif
9760 #else
9761 #ifdef lstat
9762 #undef lstat
9763 #endif
9764 #define lstat(_x, _y) stat(_x, _y)
9765 #endif
9766
9767 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9768
9769 static int
9770 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9771 {
9772     char fileified[NAM$C_MAXRSS+1];
9773     char temp_fspec[NAM$C_MAXRSS+300];
9774     int retval = -1;
9775     int saved_errno, saved_vaxc_errno;
9776
9777     if (!fspec) return retval;
9778     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9779     strcpy(temp_fspec, fspec);
9780     if (statbufp == (Stat_t *) &PL_statcache)
9781       do_tovmsspec(temp_fspec,namecache,0);
9782     if (decc_bug_devnull != 0) {
9783       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9784         memset(statbufp,0,sizeof *statbufp);
9785         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9786         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9787         statbufp->st_uid = 0x00010001;
9788         statbufp->st_gid = 0x0001;
9789         time((time_t *)&statbufp->st_mtime);
9790         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9791         return 0;
9792       }
9793     }
9794
9795     /* Try for a directory name first.  If fspec contains a filename without
9796      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9797      * and sea:[wine.dark]water. exist, we prefer the directory here.
9798      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9799      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9800      * the file with null type, specify this by calling flex_stat() with
9801      * a '.' at the end of fspec.
9802      *
9803      * If we are in Posix filespec mode, accept the filename as is.
9804      */
9805 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9806   if (decc_posix_compliant_pathnames == 0) {
9807 #endif
9808     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9809       if (lstat_flag == 0)
9810         retval = stat(fileified,(stat_t *) statbufp);
9811       else
9812         retval = lstat(fileified,(stat_t *) statbufp);
9813       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9814         strcpy(namecache,fileified);
9815     }
9816     if (retval) {
9817       if (lstat_flag == 0)
9818         retval = stat(temp_fspec,(stat_t *) statbufp);
9819       else
9820         retval = lstat(temp_fspec,(stat_t *) statbufp);
9821     }
9822 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9823   } else {
9824     if (lstat_flag == 0)
9825       retval = stat(temp_fspec,(stat_t *) statbufp);
9826     else
9827       retval = lstat(temp_fspec,(stat_t *) statbufp);
9828   }
9829 #endif
9830     if (!retval) {
9831       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
9832 #ifndef _USE_STD_STAT
9833       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9834       statbufp->st_devnam[63] = 0;
9835       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9836 #else
9837     /* todo:
9838      * The device is only encoded so that Perl_cando can use it to
9839      * look up ACLS.  So rmsexpand it to the 255 character version
9840      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9841      * for long filenames and symbolic links first.  This also seems
9842      * to remove the need for a namecache that could be stale.
9843      */
9844 #endif
9845 #     ifdef RTL_USES_UTC
9846 #     ifdef VMSISH_TIME
9847       if (VMSISH_TIME) {
9848         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9849         statbufp->st_atime = _toloc(statbufp->st_atime);
9850         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9851       }
9852 #     endif
9853 #     else
9854 #     ifdef VMSISH_TIME
9855       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9856 #     else
9857       if (1) {
9858 #     endif
9859         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9860         statbufp->st_atime = _toutc(statbufp->st_atime);
9861         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9862       }
9863 #     endif
9864     }
9865     /* If we were successful, leave errno where we found it */
9866     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9867     return retval;
9868
9869 }  /* end of flex_stat_int() */
9870
9871
9872 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9873 int
9874 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9875 {
9876    return flex_stat_int(fspec, statbufp, 0);
9877 }
9878 /*}}}*/
9879
9880 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9881 int
9882 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9883 {
9884    return flex_stat_int(fspec, statbufp, 1);
9885 }
9886 /*}}}*/
9887
9888
9889 /*{{{char *my_getlogin()*/
9890 /* VMS cuserid == Unix getlogin, except calling sequence */
9891 char *
9892 my_getlogin(void)
9893 {
9894     static char user[L_cuserid];
9895     return cuserid(user);
9896 }
9897 /*}}}*/
9898
9899
9900 /*  rmscopy - copy a file using VMS RMS routines
9901  *
9902  *  Copies contents and attributes of spec_in to spec_out, except owner
9903  *  and protection information.  Name and type of spec_in are used as
9904  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9905  *  should try to propagate timestamps from the input file to the output file.
9906  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9907  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9908  *  propagated to the output file at creation iff the output file specification
9909  *  did not contain an explicit name or type, and the revision date is always
9910  *  updated at the end of the copy operation.  If it is greater than 0, then
9911  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9912  *  other than the revision date should be propagated, and bit 1 indicates
9913  *  that the revision date should be propagated.
9914  *
9915  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9916  *
9917  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9918  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9919  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9920  * as part of the Perl standard distribution under the terms of the
9921  * GNU General Public License or the Perl Artistic License.  Copies
9922  * of each may be found in the Perl standard distribution.
9923  */ /* FIXME */
9924 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9925 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9926 int
9927 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9928 {
9929     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9930          rsa[NAM$C_MAXRSS], ubf[32256];
9931     unsigned long int i, sts, sts2;
9932     struct FAB fab_in, fab_out;
9933     struct RAB rab_in, rab_out;
9934     struct NAM nam;
9935     struct XABDAT xabdat;
9936     struct XABFHC xabfhc;
9937     struct XABRDT xabrdt;
9938     struct XABSUM xabsum;
9939
9940     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9941         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9942       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9943       return 0;
9944     }
9945
9946     fab_in = cc$rms_fab;
9947     fab_in.fab$l_fna = vmsin;
9948     fab_in.fab$b_fns = strlen(vmsin);
9949     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9950     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9951     fab_in.fab$l_fop = FAB$M_SQO;
9952     fab_in.fab$l_nam =  &nam;
9953     fab_in.fab$l_xab = (void *) &xabdat;
9954
9955     nam = cc$rms_nam;
9956     nam.nam$l_rsa = rsa;
9957     nam.nam$b_rss = sizeof(rsa);
9958     nam.nam$l_esa = esa;
9959     nam.nam$b_ess = sizeof (esa);
9960     nam.nam$b_esl = nam.nam$b_rsl = 0;
9961 #ifdef NAM$M_NO_SHORT_UPCASE
9962     if (decc_efs_case_preserve)
9963         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9964 #endif
9965
9966     xabdat = cc$rms_xabdat;        /* To get creation date */
9967     xabdat.xab$l_nxt = (void *) &xabfhc;
9968
9969     xabfhc = cc$rms_xabfhc;        /* To get record length */
9970     xabfhc.xab$l_nxt = (void *) &xabsum;
9971
9972     xabsum = cc$rms_xabsum;        /* To get key and area information */
9973
9974     if (!((sts = sys$open(&fab_in)) & 1)) {
9975       set_vaxc_errno(sts);
9976       switch (sts) {
9977         case RMS$_FNF: case RMS$_DNF:
9978           set_errno(ENOENT); break;
9979         case RMS$_DIR:
9980           set_errno(ENOTDIR); break;
9981         case RMS$_DEV:
9982           set_errno(ENODEV); break;
9983         case RMS$_SYN:
9984           set_errno(EINVAL); break;
9985         case RMS$_PRV:
9986           set_errno(EACCES); break;
9987         default:
9988           set_errno(EVMSERR);
9989       }
9990       return 0;
9991     }
9992
9993     fab_out = fab_in;
9994     fab_out.fab$w_ifi = 0;
9995     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9996     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9997     fab_out.fab$l_fop = FAB$M_SQO;
9998     fab_out.fab$l_fna = vmsout;
9999     fab_out.fab$b_fns = strlen(vmsout);
10000     fab_out.fab$l_dna = nam.nam$l_name;
10001     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10002
10003     if (preserve_dates == 0) {  /* Act like DCL COPY */
10004       nam.nam$b_nop |= NAM$M_SYNCHK;
10005       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10006       if (!((sts = sys$parse(&fab_out)) & 1)) {
10007         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10008         set_vaxc_errno(sts);
10009         return 0;
10010       }
10011       fab_out.fab$l_xab = (void *) &xabdat;
10012       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10013     }
10014     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10015     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10016       preserve_dates =0;      /* bitmask from this point forward   */
10017
10018     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10019     if (!((sts = sys$create(&fab_out)) & 1)) {
10020       set_vaxc_errno(sts);
10021       switch (sts) {
10022         case RMS$_DNF:
10023           set_errno(ENOENT); break;
10024         case RMS$_DIR:
10025           set_errno(ENOTDIR); break;
10026         case RMS$_DEV:
10027           set_errno(ENODEV); break;
10028         case RMS$_SYN:
10029           set_errno(EINVAL); break;
10030         case RMS$_PRV:
10031           set_errno(EACCES); break;
10032         default:
10033           set_errno(EVMSERR);
10034       }
10035       return 0;
10036     }
10037     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10038     if (preserve_dates & 2) {
10039       /* sys$close() will process xabrdt, not xabdat */
10040       xabrdt = cc$rms_xabrdt;
10041 #ifndef __GNUC__
10042       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10043 #else
10044       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10045        * is unsigned long[2], while DECC & VAXC use a struct */
10046       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10047 #endif
10048       fab_out.fab$l_xab = (void *) &xabrdt;
10049     }
10050
10051     rab_in = cc$rms_rab;
10052     rab_in.rab$l_fab = &fab_in;
10053     rab_in.rab$l_rop = RAB$M_BIO;
10054     rab_in.rab$l_ubf = ubf;
10055     rab_in.rab$w_usz = sizeof ubf;
10056     if (!((sts = sys$connect(&rab_in)) & 1)) {
10057       sys$close(&fab_in); sys$close(&fab_out);
10058       set_errno(EVMSERR); set_vaxc_errno(sts);
10059       return 0;
10060     }
10061
10062     rab_out = cc$rms_rab;
10063     rab_out.rab$l_fab = &fab_out;
10064     rab_out.rab$l_rbf = ubf;
10065     if (!((sts = sys$connect(&rab_out)) & 1)) {
10066       sys$close(&fab_in); sys$close(&fab_out);
10067       set_errno(EVMSERR); set_vaxc_errno(sts);
10068       return 0;
10069     }
10070
10071     while ((sts = sys$read(&rab_in))) {  /* always true  */
10072       if (sts == RMS$_EOF) break;
10073       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10074       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10075         sys$close(&fab_in); sys$close(&fab_out);
10076         set_errno(EVMSERR); set_vaxc_errno(sts);
10077         return 0;
10078       }
10079     }
10080
10081     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10082     sys$close(&fab_in);  sys$close(&fab_out);
10083     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10084     if (!(sts & 1)) {
10085       set_errno(EVMSERR); set_vaxc_errno(sts);
10086       return 0;
10087     }
10088
10089     return 1;
10090
10091 }  /* end of rmscopy() */
10092 #else
10093 /* ODS-5 support version */
10094 int
10095 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10096 {
10097     char *vmsin, * vmsout, *esa, *esa_out,
10098          *rsa, *ubf;
10099     unsigned long int i, sts, sts2;
10100     struct FAB fab_in, fab_out;
10101     struct RAB rab_in, rab_out;
10102     struct NAML nam;
10103     struct NAML nam_out;
10104     struct XABDAT xabdat;
10105     struct XABFHC xabfhc;
10106     struct XABRDT xabrdt;
10107     struct XABSUM xabsum;
10108
10109     Newx(vmsin, VMS_MAXRSS, char);
10110     Newx(vmsout, VMS_MAXRSS, char);
10111     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10112         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10113       Safefree(vmsin);
10114       Safefree(vmsout);
10115       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10116       return 0;
10117     }
10118
10119     Newx(esa, VMS_MAXRSS, char);
10120     nam = cc$rms_naml;
10121     fab_in = cc$rms_fab;
10122     fab_in.fab$l_fna = (char *) -1;
10123     fab_in.fab$b_fns = 0;
10124     nam.naml$l_long_filename = vmsin;
10125     nam.naml$l_long_filename_size = strlen(vmsin);
10126     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10127     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10128     fab_in.fab$l_fop = FAB$M_SQO;
10129     fab_in.fab$l_naml =  &nam;
10130     fab_in.fab$l_xab = (void *) &xabdat;
10131
10132     Newx(rsa, VMS_MAXRSS, char);
10133     nam.naml$l_rsa = NULL;
10134     nam.naml$b_rss = 0;
10135     nam.naml$l_long_result = rsa;
10136     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10137     nam.naml$l_esa = NULL;
10138     nam.naml$b_ess = 0;
10139     nam.naml$l_long_expand = esa;
10140     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10141     nam.naml$b_esl = nam.naml$b_rsl = 0;
10142     nam.naml$l_long_expand_size = 0;
10143     nam.naml$l_long_result_size = 0;
10144 #ifdef NAM$M_NO_SHORT_UPCASE
10145     if (decc_efs_case_preserve)
10146         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10147 #endif
10148
10149     xabdat = cc$rms_xabdat;        /* To get creation date */
10150     xabdat.xab$l_nxt = (void *) &xabfhc;
10151
10152     xabfhc = cc$rms_xabfhc;        /* To get record length */
10153     xabfhc.xab$l_nxt = (void *) &xabsum;
10154
10155     xabsum = cc$rms_xabsum;        /* To get key and area information */
10156
10157     if (!((sts = sys$open(&fab_in)) & 1)) {
10158       Safefree(vmsin);
10159       Safefree(vmsout);
10160       Safefree(esa);
10161       Safefree(rsa);
10162       set_vaxc_errno(sts);
10163       switch (sts) {
10164         case RMS$_FNF: case RMS$_DNF:
10165           set_errno(ENOENT); break;
10166         case RMS$_DIR:
10167           set_errno(ENOTDIR); break;
10168         case RMS$_DEV:
10169           set_errno(ENODEV); break;
10170         case RMS$_SYN:
10171           set_errno(EINVAL); break;
10172         case RMS$_PRV:
10173           set_errno(EACCES); break;
10174         default:
10175           set_errno(EVMSERR);
10176       }
10177       return 0;
10178     }
10179
10180     nam_out = nam;
10181     fab_out = fab_in;
10182     fab_out.fab$w_ifi = 0;
10183     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10184     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10185     fab_out.fab$l_fop = FAB$M_SQO;
10186     fab_out.fab$l_naml = &nam_out;
10187     fab_out.fab$l_fna = (char *) -1;
10188     fab_out.fab$b_fns = 0;
10189     nam_out.naml$l_long_filename = vmsout;
10190     nam_out.naml$l_long_filename_size = strlen(vmsout);
10191     fab_out.fab$l_dna = (char *) -1;
10192     fab_out.fab$b_dns = 0;
10193     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10194     nam_out.naml$l_long_defname_size =
10195         nam.naml$l_long_name ?
10196            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10197
10198     Newx(esa_out, VMS_MAXRSS, char);
10199     nam_out.naml$l_rsa = NULL;
10200     nam_out.naml$b_rss = 0;
10201     nam_out.naml$l_long_result = NULL;
10202     nam_out.naml$l_long_result_alloc = 0;
10203     nam_out.naml$l_esa = NULL;
10204     nam_out.naml$b_ess = 0;
10205     nam_out.naml$l_long_expand = esa_out;
10206     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10207
10208     if (preserve_dates == 0) {  /* Act like DCL COPY */
10209       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10210       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10211       if (!((sts = sys$parse(&fab_out)) & 1)) {
10212         Safefree(vmsin);
10213         Safefree(vmsout);
10214         Safefree(esa);
10215         Safefree(rsa);
10216         Safefree(esa_out);
10217         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10218         set_vaxc_errno(sts);
10219         return 0;
10220       }
10221       fab_out.fab$l_xab = (void *) &xabdat;
10222       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10223     }
10224     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10225       preserve_dates =0;      /* bitmask from this point forward   */
10226
10227     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10228     if (!((sts = sys$create(&fab_out)) & 1)) {
10229       Safefree(vmsin);
10230       Safefree(vmsout);
10231       Safefree(esa);
10232       Safefree(rsa);
10233       Safefree(esa_out);
10234       set_vaxc_errno(sts);
10235       switch (sts) {
10236         case RMS$_DNF:
10237           set_errno(ENOENT); break;
10238         case RMS$_DIR:
10239           set_errno(ENOTDIR); break;
10240         case RMS$_DEV:
10241           set_errno(ENODEV); break;
10242         case RMS$_SYN:
10243           set_errno(EINVAL); break;
10244         case RMS$_PRV:
10245           set_errno(EACCES); break;
10246         default:
10247           set_errno(EVMSERR);
10248       }
10249       return 0;
10250     }
10251     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10252     if (preserve_dates & 2) {
10253       /* sys$close() will process xabrdt, not xabdat */
10254       xabrdt = cc$rms_xabrdt;
10255 #ifndef __GNUC__
10256       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10257 #else
10258       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10259        * is unsigned long[2], while DECC & VAXC use a struct */
10260       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10261 #endif
10262       fab_out.fab$l_xab = (void *) &xabrdt;
10263     }
10264
10265     Newx(ubf, 32256, char);
10266     rab_in = cc$rms_rab;
10267     rab_in.rab$l_fab = &fab_in;
10268     rab_in.rab$l_rop = RAB$M_BIO;
10269     rab_in.rab$l_ubf = ubf;
10270     rab_in.rab$w_usz = 32256;
10271     if (!((sts = sys$connect(&rab_in)) & 1)) {
10272       sys$close(&fab_in); sys$close(&fab_out);
10273       Safefree(vmsin);
10274       Safefree(vmsout);
10275       Safefree(esa);
10276       Safefree(ubf);
10277       Safefree(rsa);
10278       Safefree(esa_out);
10279       set_errno(EVMSERR); set_vaxc_errno(sts);
10280       return 0;
10281     }
10282
10283     rab_out = cc$rms_rab;
10284     rab_out.rab$l_fab = &fab_out;
10285     rab_out.rab$l_rbf = ubf;
10286     if (!((sts = sys$connect(&rab_out)) & 1)) {
10287       sys$close(&fab_in); sys$close(&fab_out);
10288       Safefree(vmsin);
10289       Safefree(vmsout);
10290       Safefree(esa);
10291       Safefree(ubf);
10292       Safefree(rsa);
10293       Safefree(esa_out);
10294       set_errno(EVMSERR); set_vaxc_errno(sts);
10295       return 0;
10296     }
10297
10298     while ((sts = sys$read(&rab_in))) {  /* always true  */
10299       if (sts == RMS$_EOF) break;
10300       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10301       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10302         sys$close(&fab_in); sys$close(&fab_out);
10303         Safefree(vmsin);
10304         Safefree(vmsout);
10305         Safefree(esa);
10306         Safefree(ubf);
10307         Safefree(rsa);
10308         Safefree(esa_out);
10309         set_errno(EVMSERR); set_vaxc_errno(sts);
10310         return 0;
10311       }
10312     }
10313
10314
10315     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10316     sys$close(&fab_in);  sys$close(&fab_out);
10317     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10318     if (!(sts & 1)) {
10319       Safefree(vmsin);
10320       Safefree(vmsout);
10321       Safefree(esa);
10322       Safefree(ubf);
10323       Safefree(rsa);
10324       Safefree(esa_out);
10325       set_errno(EVMSERR); set_vaxc_errno(sts);
10326       return 0;
10327     }
10328
10329     Safefree(vmsin);
10330     Safefree(vmsout);
10331     Safefree(esa);
10332     Safefree(ubf);
10333     Safefree(rsa);
10334     Safefree(esa_out);
10335     return 1;
10336
10337 }  /* end of rmscopy() */
10338 #endif
10339 /*}}}*/
10340
10341
10342 /***  The following glue provides 'hooks' to make some of the routines
10343  * from this file available from Perl.  These routines are sufficiently
10344  * basic, and are required sufficiently early in the build process,
10345  * that's it's nice to have them available to miniperl as well as the
10346  * full Perl, so they're set up here instead of in an extension.  The
10347  * Perl code which handles importation of these names into a given
10348  * package lives in [.VMS]Filespec.pm in @INC.
10349  */
10350
10351 void
10352 rmsexpand_fromperl(pTHX_ CV *cv)
10353 {
10354   dXSARGS;
10355   char *fspec, *defspec = NULL, *rslt;
10356   STRLEN n_a;
10357
10358   if (!items || items > 2)
10359     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10360   fspec = SvPV(ST(0),n_a);
10361   if (!fspec || !*fspec) XSRETURN_UNDEF;
10362   if (items == 2) defspec = SvPV(ST(1),n_a);
10363
10364   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10365   ST(0) = sv_newmortal();
10366   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10367   XSRETURN(1);
10368 }
10369
10370 void
10371 vmsify_fromperl(pTHX_ CV *cv)
10372 {
10373   dXSARGS;
10374   char *vmsified;
10375   STRLEN n_a;
10376
10377   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10378   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10379   ST(0) = sv_newmortal();
10380   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10381   XSRETURN(1);
10382 }
10383
10384 void
10385 unixify_fromperl(pTHX_ CV *cv)
10386 {
10387   dXSARGS;
10388   char *unixified;
10389   STRLEN n_a;
10390
10391   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10392   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10393   ST(0) = sv_newmortal();
10394   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10395   XSRETURN(1);
10396 }
10397
10398 void
10399 fileify_fromperl(pTHX_ CV *cv)
10400 {
10401   dXSARGS;
10402   char *fileified;
10403   STRLEN n_a;
10404
10405   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10406   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10407   ST(0) = sv_newmortal();
10408   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10409   XSRETURN(1);
10410 }
10411
10412 void
10413 pathify_fromperl(pTHX_ CV *cv)
10414 {
10415   dXSARGS;
10416   char *pathified;
10417   STRLEN n_a;
10418
10419   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10420   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10421   ST(0) = sv_newmortal();
10422   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10423   XSRETURN(1);
10424 }
10425
10426 void
10427 vmspath_fromperl(pTHX_ CV *cv)
10428 {
10429   dXSARGS;
10430   char *vmspath;
10431   STRLEN n_a;
10432
10433   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10434   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10435   ST(0) = sv_newmortal();
10436   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10437   XSRETURN(1);
10438 }
10439
10440 void
10441 unixpath_fromperl(pTHX_ CV *cv)
10442 {
10443   dXSARGS;
10444   char *unixpath;
10445   STRLEN n_a;
10446
10447   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10448   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10449   ST(0) = sv_newmortal();
10450   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10451   XSRETURN(1);
10452 }
10453
10454 void
10455 candelete_fromperl(pTHX_ CV *cv)
10456 {
10457   dXSARGS;
10458   char fspec[NAM$C_MAXRSS+1], *fsp;
10459   SV *mysv;
10460   IO *io;
10461   STRLEN n_a;
10462
10463   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10464
10465   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10466   if (SvTYPE(mysv) == SVt_PVGV) {
10467     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10468       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10469       ST(0) = &PL_sv_no;
10470       XSRETURN(1);
10471     }
10472     fsp = fspec;
10473   }
10474   else {
10475     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10476       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10477       ST(0) = &PL_sv_no;
10478       XSRETURN(1);
10479     }
10480   }
10481
10482   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10483   XSRETURN(1);
10484 }
10485
10486 void
10487 rmscopy_fromperl(pTHX_ CV *cv)
10488 {
10489   dXSARGS;
10490   char *inspec, *outspec, *inp, *outp;
10491   int date_flag;
10492   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10493                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10494   unsigned long int sts;
10495   SV *mysv;
10496   IO *io;
10497   STRLEN n_a;
10498
10499   if (items < 2 || items > 3)
10500     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10501
10502   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10503   Newx(inspec, VMS_MAXRSS, char);
10504   if (SvTYPE(mysv) == SVt_PVGV) {
10505     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10506       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10507       ST(0) = &PL_sv_no;
10508       Safefree(inspec);
10509       XSRETURN(1);
10510     }
10511     inp = inspec;
10512   }
10513   else {
10514     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10515       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10516       ST(0) = &PL_sv_no;
10517       Safefree(inspec);
10518       XSRETURN(1);
10519     }
10520   }
10521   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10522   Newx(outspec, VMS_MAXRSS, char);
10523   if (SvTYPE(mysv) == SVt_PVGV) {
10524     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10525       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10526       ST(0) = &PL_sv_no;
10527       Safefree(inspec);
10528       Safefree(outspec);
10529       XSRETURN(1);
10530     }
10531     outp = outspec;
10532   }
10533   else {
10534     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10535       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10536       ST(0) = &PL_sv_no;
10537       Safefree(inspec);
10538       Safefree(outspec);
10539       XSRETURN(1);
10540     }
10541   }
10542   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10543
10544   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10545   Safefree(inspec);
10546   Safefree(outspec);
10547   XSRETURN(1);
10548 }
10549
10550 /* The mod2fname is limited to shorter filenames by design, so it should
10551  * not be modified to support longer EFS pathnames
10552  */
10553 void
10554 mod2fname(pTHX_ CV *cv)
10555 {
10556   dXSARGS;
10557   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10558        workbuff[NAM$C_MAXRSS*1 + 1];
10559   int total_namelen = 3, counter, num_entries;
10560   /* ODS-5 ups this, but we want to be consistent, so... */
10561   int max_name_len = 39;
10562   AV *in_array = (AV *)SvRV(ST(0));
10563
10564   num_entries = av_len(in_array);
10565
10566   /* All the names start with PL_. */
10567   strcpy(ultimate_name, "PL_");
10568
10569   /* Clean up our working buffer */
10570   Zero(work_name, sizeof(work_name), char);
10571
10572   /* Run through the entries and build up a working name */
10573   for(counter = 0; counter <= num_entries; counter++) {
10574     /* If it's not the first name then tack on a __ */
10575     if (counter) {
10576       strcat(work_name, "__");
10577     }
10578     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10579                            PL_na));
10580   }
10581
10582   /* Check to see if we actually have to bother...*/
10583   if (strlen(work_name) + 3 <= max_name_len) {
10584     strcat(ultimate_name, work_name);
10585   } else {
10586     /* It's too darned big, so we need to go strip. We use the same */
10587     /* algorithm as xsubpp does. First, strip out doubled __ */
10588     char *source, *dest, last;
10589     dest = workbuff;
10590     last = 0;
10591     for (source = work_name; *source; source++) {
10592       if (last == *source && last == '_') {
10593         continue;
10594       }
10595       *dest++ = *source;
10596       last = *source;
10597     }
10598     /* Go put it back */
10599     strcpy(work_name, workbuff);
10600     /* Is it still too big? */
10601     if (strlen(work_name) + 3 > max_name_len) {
10602       /* Strip duplicate letters */
10603       last = 0;
10604       dest = workbuff;
10605       for (source = work_name; *source; source++) {
10606         if (last == toupper(*source)) {
10607         continue;
10608         }
10609         *dest++ = *source;
10610         last = toupper(*source);
10611       }
10612       strcpy(work_name, workbuff);
10613     }
10614
10615     /* Is it *still* too big? */
10616     if (strlen(work_name) + 3 > max_name_len) {
10617       /* Too bad, we truncate */
10618       work_name[max_name_len - 2] = 0;
10619     }
10620     strcat(ultimate_name, work_name);
10621   }
10622
10623   /* Okay, return it */
10624   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10625   XSRETURN(1);
10626 }
10627
10628 void
10629 hushexit_fromperl(pTHX_ CV *cv)
10630 {
10631     dXSARGS;
10632
10633     if (items > 0) {
10634         VMSISH_HUSHED = SvTRUE(ST(0));
10635     }
10636     ST(0) = boolSV(VMSISH_HUSHED);
10637     XSRETURN(1);
10638 }
10639
10640 #ifdef HAS_SYMLINK
10641 static char *
10642 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10643
10644 void
10645 vms_realpath_fromperl(pTHX_ CV *cv)
10646 {
10647   dXSARGS;
10648   char *fspec, *rslt_spec, *rslt;
10649   STRLEN n_a;
10650
10651   if (!items || items != 1)
10652     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10653
10654   fspec = SvPV(ST(0),n_a);
10655   if (!fspec || !*fspec) XSRETURN_UNDEF;
10656
10657   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10658   rslt = do_vms_realpath(fspec, rslt_spec);
10659   ST(0) = sv_newmortal();
10660   if (rslt != NULL)
10661     sv_usepvn(ST(0),rslt,strlen(rslt));
10662   else
10663     Safefree(rslt_spec);
10664   XSRETURN(1);
10665 }
10666 #endif
10667
10668 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10669 int do_vms_case_tolerant(void);
10670
10671 void
10672 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10673 {
10674   dXSARGS;
10675   ST(0) = boolSV(do_vms_case_tolerant());
10676   XSRETURN(1);
10677 }
10678 #endif
10679
10680 void
10681 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10682                           struct interp_intern *dst)
10683 {
10684     memcpy(dst,src,sizeof(struct interp_intern));
10685 }
10686
10687 void
10688 Perl_sys_intern_clear(pTHX)
10689 {
10690 }
10691
10692 void
10693 Perl_sys_intern_init(pTHX)
10694 {
10695     unsigned int ix = RAND_MAX;
10696     double x;
10697
10698     VMSISH_HUSHED = 0;
10699
10700     /* fix me later to track running under GNV */
10701     /* this allows some limited testing */
10702     MY_POSIX_EXIT = decc_filename_unix_report;
10703
10704     x = (float)ix;
10705     MY_INV_RAND_MAX = 1./x;
10706 }
10707
10708 void
10709 init_os_extras(void)
10710 {
10711   dTHX;
10712   char* file = __FILE__;
10713   char temp_buff[512];
10714   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10715     no_translate_barewords = TRUE;
10716   } else {
10717     no_translate_barewords = FALSE;
10718   }
10719
10720   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10721   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10722   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10723   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10724   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10725   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10726   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10727   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10728   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10729   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10730   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10731 #ifdef HAS_SYMLINK
10732   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10733 #endif
10734 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10735   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10736 #endif
10737
10738   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10739
10740   return;
10741 }
10742
10743 #ifdef HAS_SYMLINK
10744
10745 #if __CRTL_VER == 80200000
10746 /* This missed getting in to the DECC SDK for 8.2 */
10747 char *realpath(const char *file_name, char * resolved_name, ...);
10748 #endif
10749
10750 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10751 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10752  * The perl fallback routine to provide realpath() is not as efficient
10753  * on OpenVMS.
10754  */
10755 static char *
10756 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10757 {
10758     return realpath(filespec, outbuf);
10759 }
10760
10761 /*}}}*/
10762 /* External entry points */
10763 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10764 { return do_vms_realpath(filespec, outbuf); }
10765 #else
10766 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10767 { return NULL; }
10768 #endif
10769
10770
10771 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10772 /* case_tolerant */
10773
10774 /*{{{int do_vms_case_tolerant(void)*/
10775 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10776  * controlled by a process setting.
10777  */
10778 int do_vms_case_tolerant(void)
10779 {
10780     return vms_process_case_tolerant;
10781 }
10782 /*}}}*/
10783 /* External entry points */
10784 int Perl_vms_case_tolerant(void)
10785 { return do_vms_case_tolerant(); }
10786 #else
10787 int Perl_vms_case_tolerant(void)
10788 { return vms_process_case_tolerant; }
10789 #endif
10790
10791
10792  /* Start of DECC RTL Feature handling */
10793
10794 static int sys_trnlnm
10795    (const char * logname,
10796     char * value,
10797     int value_len)
10798 {
10799     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10800     const unsigned long attr = LNM$M_CASE_BLIND;
10801     struct dsc$descriptor_s name_dsc;
10802     int status;
10803     unsigned short result;
10804     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10805                                 {0, 0, 0, 0}};
10806
10807     name_dsc.dsc$w_length = strlen(logname);
10808     name_dsc.dsc$a_pointer = (char *)logname;
10809     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10810     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10811
10812     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10813
10814     if ($VMS_STATUS_SUCCESS(status)) {
10815
10816          /* Null terminate and return the string */
10817         /*--------------------------------------*/
10818         value[result] = 0;
10819     }
10820
10821     return status;
10822 }
10823
10824 static int sys_crelnm
10825    (const char * logname,
10826     const char * value)
10827 {
10828     int ret_val;
10829     const char * proc_table = "LNM$PROCESS_TABLE";
10830     struct dsc$descriptor_s proc_table_dsc;
10831     struct dsc$descriptor_s logname_dsc;
10832     struct itmlst_3 item_list[2];
10833
10834     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10835     proc_table_dsc.dsc$w_length = strlen(proc_table);
10836     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10837     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10838
10839     logname_dsc.dsc$a_pointer = (char *) logname;
10840     logname_dsc.dsc$w_length = strlen(logname);
10841     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10842     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10843
10844     item_list[0].buflen = strlen(value);
10845     item_list[0].itmcode = LNM$_STRING;
10846     item_list[0].bufadr = (char *)value;
10847     item_list[0].retlen = NULL;
10848
10849     item_list[1].buflen = 0;
10850     item_list[1].itmcode = 0;
10851
10852     ret_val = sys$crelnm
10853                        (NULL,
10854                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10855                         (const struct dsc$descriptor_s *)&logname_dsc,
10856                         NULL,
10857                         (const struct item_list_3 *) item_list);
10858
10859     return ret_val;
10860 }
10861
10862
10863 /* C RTL Feature settings */
10864
10865 static int set_features
10866    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10867     int (* cli_routine)(void),  /* Not documented */
10868     void *image_info)           /* Not documented */
10869 {
10870     int status;
10871     int s;
10872     int dflt;
10873     char* str;
10874     char val_str[10];
10875 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
10876     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10877     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10878     unsigned long case_perm;
10879     unsigned long case_image;
10880 #endif
10881
10882     /* Allow an exception to bring Perl into the VMS debugger */
10883     vms_debug_on_exception = 0;
10884     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
10885     if ($VMS_STATUS_SUCCESS(status)) {
10886        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10887          vms_debug_on_exception = 1;
10888        else
10889          vms_debug_on_exception = 0;
10890     }
10891
10892
10893     /* hacks to see if known bugs are still present for testing */
10894
10895     /* Readdir is returning filenames in VMS syntax always */
10896     decc_bug_readdir_efs1 = 1;
10897     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10898     if ($VMS_STATUS_SUCCESS(status)) {
10899        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10900          decc_bug_readdir_efs1 = 1;
10901        else
10902          decc_bug_readdir_efs1 = 0;
10903     }
10904
10905     /* PCP mode requires creating /dev/null special device file */
10906     decc_bug_devnull = 1;
10907     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10908     if ($VMS_STATUS_SUCCESS(status)) {
10909        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10910           decc_bug_devnull = 1;
10911        else
10912           decc_bug_devnull = 0;
10913     }
10914
10915     /* fgetname returning a VMS name in UNIX mode */
10916     decc_bug_fgetname = 1;
10917     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10918     if ($VMS_STATUS_SUCCESS(status)) {
10919       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10920         decc_bug_fgetname = 1;
10921       else
10922         decc_bug_fgetname = 0;
10923     }
10924
10925     /* UNIX directory names with no paths are broken in a lot of places */
10926     decc_dir_barename = 1;
10927     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10928     if ($VMS_STATUS_SUCCESS(status)) {
10929       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10930         decc_dir_barename = 1;
10931       else
10932         decc_dir_barename = 0;
10933     }
10934
10935 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10936     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10937     if (s >= 0) {
10938         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10939         if (decc_disable_to_vms_logname_translation < 0)
10940             decc_disable_to_vms_logname_translation = 0;
10941     }
10942
10943     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10944     if (s >= 0) {
10945         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10946         if (decc_efs_case_preserve < 0)
10947             decc_efs_case_preserve = 0;
10948     }
10949
10950     s = decc$feature_get_index("DECC$EFS_CHARSET");
10951     if (s >= 0) {
10952         decc_efs_charset = decc$feature_get_value(s, 1);
10953         if (decc_efs_charset < 0)
10954             decc_efs_charset = 0;
10955     }
10956
10957     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10958     if (s >= 0) {
10959         decc_filename_unix_report = decc$feature_get_value(s, 1);
10960         if (decc_filename_unix_report > 0)
10961             decc_filename_unix_report = 1;
10962         else
10963             decc_filename_unix_report = 0;
10964     }
10965
10966     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10967     if (s >= 0) {
10968         decc_filename_unix_only = decc$feature_get_value(s, 1);
10969         if (decc_filename_unix_only > 0) {
10970             decc_filename_unix_only = 1;
10971         }
10972         else {
10973             decc_filename_unix_only = 0;
10974         }
10975     }
10976
10977     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10978     if (s >= 0) {
10979         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10980         if (decc_filename_unix_no_version < 0)
10981             decc_filename_unix_no_version = 0;
10982     }
10983
10984     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10985     if (s >= 0) {
10986         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10987         if (decc_readdir_dropdotnotype < 0)
10988             decc_readdir_dropdotnotype = 0;
10989     }
10990
10991     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10992     if ($VMS_STATUS_SUCCESS(status)) {
10993         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10994         if (s >= 0) {
10995             dflt = decc$feature_get_value(s, 4);
10996             if (dflt > 0) {
10997                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10998                 if (decc_disable_posix_root <= 0) {
10999                     decc$feature_set_value(s, 1, 1);
11000                     decc_disable_posix_root = 1;
11001                 }
11002             }
11003             else {
11004                 /* Traditionally Perl assumes this is off */
11005                 decc_disable_posix_root = 1;
11006                 decc$feature_set_value(s, 1, 1);
11007             }
11008         }
11009     }
11010
11011 #if __CRTL_VER >= 80200000
11012     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11013     if (s >= 0) {
11014         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11015         if (decc_posix_compliant_pathnames < 0)
11016             decc_posix_compliant_pathnames = 0;
11017         if (decc_posix_compliant_pathnames > 4)
11018             decc_posix_compliant_pathnames = 0;
11019     }
11020
11021 #endif
11022 #else
11023     status = sys_trnlnm
11024         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11025     if ($VMS_STATUS_SUCCESS(status)) {
11026         val_str[0] = _toupper(val_str[0]);
11027         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11028            decc_disable_to_vms_logname_translation = 1;
11029         }
11030     }
11031
11032 #ifndef __VAX
11033     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", 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_efs_case_preserve = 1;
11038         }
11039     }
11040 #endif
11041
11042     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11043     if ($VMS_STATUS_SUCCESS(status)) {
11044         val_str[0] = _toupper(val_str[0]);
11045         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11046            decc_filename_unix_report = 1;
11047         }
11048     }
11049     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11050     if ($VMS_STATUS_SUCCESS(status)) {
11051         val_str[0] = _toupper(val_str[0]);
11052         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11053            decc_filename_unix_only = 1;
11054            decc_filename_unix_report = 1;
11055         }
11056     }
11057     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11058     if ($VMS_STATUS_SUCCESS(status)) {
11059         val_str[0] = _toupper(val_str[0]);
11060         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11061            decc_filename_unix_no_version = 1;
11062         }
11063     }
11064     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11065     if ($VMS_STATUS_SUCCESS(status)) {
11066         val_str[0] = _toupper(val_str[0]);
11067         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11068            decc_readdir_dropdotnotype = 1;
11069         }
11070     }
11071 #endif
11072
11073 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11074
11075      /* Report true case tolerance */
11076     /*----------------------------*/
11077     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11078     if (!$VMS_STATUS_SUCCESS(status))
11079         case_perm = PPROP$K_CASE_BLIND;
11080     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11081     if (!$VMS_STATUS_SUCCESS(status))
11082         case_image = PPROP$K_CASE_BLIND;
11083     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11084         (case_image == PPROP$K_CASE_SENSITIVE))
11085         vms_process_case_tolerant = 0;
11086
11087 #endif
11088
11089
11090     /* CRTL can be initialized past this point, but not before. */
11091 /*    DECC$CRTL_INIT(); */
11092
11093     return SS$_NORMAL;
11094 }
11095
11096 #ifdef __DECC
11097 /* DECC dependent attributes */
11098 #if __DECC_VER < 60560002
11099 #define relative
11100 #define not_executable
11101 #else
11102 #define relative ,rel
11103 #define not_executable ,noexe
11104 #endif
11105 #pragma nostandard
11106 #pragma extern_model save
11107 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11108 #endif
11109         const __align (LONGWORD) int spare[8] = {0};
11110 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11111 /*                        NOWRT, LONG */
11112 #ifdef __DECC
11113 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11114         nowrt,noshr relative not_executable
11115 #endif
11116 const long vms_cc_features = (const long)set_features;
11117
11118 /*
11119 ** Force a reference to LIB$INITIALIZE to ensure it
11120 ** exists in the image.
11121 */
11122 int lib$initialize(void);
11123 #ifdef __DECC
11124 #pragma extern_model strict_refdef
11125 #endif
11126     int lib_init_ref = (int) lib$initialize;
11127
11128 #ifdef __DECC
11129 #pragma extern_model restore
11130 #pragma standard
11131 #endif
11132
11133 /*  End of vms.c */