vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170 #ifdef __DECC
 171 #pragma message restore
 172 #pragma member_alignment restore
 173 #endif
 174
 175 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 176 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 177 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 178 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 179 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 180 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 181 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 182 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 183 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 184 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 185 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 186
 187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 191
 192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 194
 195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 196  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 197  * the Perl facility.
 198  */
 199 #define PERL_LNM_MAX_ITER 10
 200
 201   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 203 #define MAX_DCL_SYMBOL          (8192)
 204 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 205 #else
 206 #define MAX_DCL_SYMBOL          (1024)
 207 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 208 #endif
 209
 210 static char *__mystrtolower(char *str)
 211 {
 212   if (str) for (; *str; ++str) *str= tolower(*str);
 213   return str;
 214 }
 215
 216 static struct dsc$descriptor_s fildevdsc =
 217   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 218 static struct dsc$descriptor_s crtlenvdsc =
 219   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 222 static struct dsc$descriptor_s **env_tables = defenv;
 223 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 224
 225 /* True if we shouldn't treat barewords as logicals during directory */
 226 /* munching */
 227 static int no_translate_barewords;
 228
 229 #ifndef RTL_USES_UTC
 230 static int tz_updated = 1;
 231 #endif
 232
 233 /* DECC Features that may need to affect how Perl interprets
 234  * displays filename information
 235  */
 236 static int decc_disable_to_vms_logname_translation = 1;
 237 static int decc_disable_posix_root = 1;
 238 int decc_efs_case_preserve = 0;
 239 static int decc_efs_charset = 0;
 240 static int decc_filename_unix_no_version = 0;
 241 static int decc_filename_unix_only = 0;
 242 int decc_filename_unix_report = 0;
 243 int decc_posix_compliant_pathnames = 0;
 244 int decc_readdir_dropdotnotype = 0;
 245 static int vms_process_case_tolerant = 1;
 246
 247 /* bug workarounds if needed */
 248 int decc_bug_readdir_efs1 = 0;
 249 int decc_bug_devnull = 0;
 250 int decc_bug_fgetname = 0;
 251 int decc_dir_barename = 0;
 252
 253 /* Is this a UNIX file specification?
 254  *   No longer a simple check with EFS file specs
 255  *   For now, not a full check, but need to
 256  *   handle POSIX ^UP^ specifications
 257  *   Fixing to handle ^/ cases would require
 258  *   changes to many other conversion routines.
 259  */
 260
 261 static is_unix_filespec(const char *path)
 262 {
 263 int ret_val;
 264 const char * pch1;
 265
 266     ret_val = 0;
 267     if (strncmp(path,"\"^UP^",5) != 0) {
 268         pch1 = strchr(path, '/');
 269         if (pch1 != NULL)
 270             ret_val = 1;
 271         else {
 272
 273             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 274             if (decc_filename_unix_report || decc_filename_unix_only) {
 275             if (strcmp(path,".") == 0)
 276                 ret_val = 1;
 277             }
 278         }
 279     }
 280     return ret_val;
 281 }
 282
 283
 284 /* my_maxidx
 285  * Routine to retrieve the maximum equivalence index for an input
 286  * logical name.  Some calls to this routine have no knowledge if
 287  * the variable is a logical or not.  So on error we return a max
 288  * index of zero.
 289  */
 290 /*{{{int my_maxidx(const char *lnm) */
 291 static int
 292 my_maxidx(const char *lnm)
 293 {
 294     int status;
 295     int midx;
 296     int attr = LNM$M_CASE_BLIND;
 297     struct dsc$descriptor lnmdsc;
 298     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 299                                 {0, 0, 0, 0}};
 300
 301     lnmdsc.dsc$w_length = strlen(lnm);
 302     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 303     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 304     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 305
 306     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 307     if ((status & 1) == 0)
 308        midx = 0;
 309
 310     return (midx);
 311 }
 312 /*}}}*/
 313
 314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 315 int
 316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 317   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 318 {
 319     const char *cp1;
 320     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 321     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 322     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 323     int midx;
 324     unsigned char acmode;
 325     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 326                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 327     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 328                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 329                                  {0, 0, 0, 0}};
 330     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 331 #if defined(PERL_IMPLICIT_CONTEXT)
 332     pTHX = NULL;
 333     if (PL_curinterp) {
 334       aTHX = PERL_GET_INTERP;
 335     } else {
 336       aTHX = NULL;
 337     }
 338 #endif
 339
 340     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 341       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 342     }
 343     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 344       *cp2 = _toupper(*cp1);
 345       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 346         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 347         return 0;
 348       }
 349     }
 350     lnmdsc.dsc$w_length = cp1 - lnm;
 351     lnmdsc.dsc$a_pointer = uplnm;
 352     uplnm[lnmdsc.dsc$w_length] = '\0';
 353     secure = flags & PERL__TRNENV_SECURE;
 354     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 355     if (!tabvec || !*tabvec) tabvec = env_tables;
 356
 357     for (curtab = 0; tabvec[curtab]; curtab++) {
 358       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 359         if (!ivenv && !secure) {
 360           char *eq, *end;
 361           int i;
 362           if (!environ) {
 363             ivenv = 1;
 364             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 365             continue;
 366           }
 367           retsts = SS$_NOLOGNAM;
 368           for (i = 0; environ[i]; i++) {
 369             if ((eq = strchr(environ[i],'=')) &&
 370                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 371                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 372               eq++;
 373               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 374               if (!eqvlen) continue;
 375               retsts = SS$_NORMAL;
 376               break;
 377             }
 378           }
 379           if (retsts != SS$_NOLOGNAM) break;
 380         }
 381       }
 382       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 383                !str$case_blind_compare(&tmpdsc,&clisym)) {
 384         if (!ivsym && !secure) {
 385           unsigned short int deflen = LNM$C_NAMLENGTH;
 386           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 387           /* dynamic dsc to accomodate possible long value */
 388           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 389           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 390           if (retsts & 1) {
 391             if (eqvlen > MAX_DCL_SYMBOL) {
 392               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 393               eqvlen = MAX_DCL_SYMBOL;
 394               /* Special hack--we might be called before the interpreter's */
 395               /* fully initialized, in which case either thr or PL_curcop */
 396               /* might be bogus. We have to check, since ckWARN needs them */
 397               /* both to be valid if running threaded */
 398                 if (ckWARN(WARN_MISC)) {
 399                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 400                 }
 401             }
 402             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 403           }
 404           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 405           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 406           if (retsts == LIB$_NOSUCHSYM) continue;
 407           break;
 408         }
 409       }
 410       else if (!ivlnm) {
 411         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 412           midx = my_maxidx(lnm);
 413           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 414             lnmlst[1].bufadr = cp2;
 415             eqvlen = 0;
 416             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 417             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 418             if (retsts == SS$_NOLOGNAM) break;
 419             /* PPFs have a prefix */
 420             if (
 421 #if INTSIZE == 4
 422                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 423 #endif
 424                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 425                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 426                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 427                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 428                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 429               memmove(eqv,eqv+4,eqvlen-4);
 430               eqvlen -= 4;
 431             }
 432             cp2 += eqvlen;
 433             *cp2 = '\0';
 434           }
 435           if ((retsts == SS$_IVLOGNAM) ||
 436               (retsts == SS$_NOLOGNAM)) { continue; }
 437         }
 438         else {
 439           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 440           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 441           if (retsts == SS$_NOLOGNAM) continue;
 442           eqv[eqvlen] = '\0';
 443         }
 444         eqvlen = strlen(eqv);
 445         break;
 446       }
 447     }
 448     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 449     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 450              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 451              retsts == SS$_NOLOGNAM) {
 452       set_errno(EINVAL);  set_vaxc_errno(retsts);
 453     }
 454     else _ckvmssts(retsts);
 455     return 0;
 456 }  /* end of vmstrnenv */
 457 /*}}}*/
 458
 459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 460 /* Define as a function so we can access statics. */
 461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 462 {
 463   return vmstrnenv(lnm,eqv,idx,fildev,
 464 #ifdef SECURE_INTERNAL_GETENV
 465                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 466 #else
 467                    0
 468 #endif
 469                                                                               );
 470 }
 471 /*}}}*/
 472
 473 /* my_getenv
 474  * Note: Uses Perl temp to store result so char * can be returned to
 475  * caller; this pointer will be invalidated at next Perl statement
 476  * transition.
 477  * We define this as a function rather than a macro in terms of my_getenv_len()
 478  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 479  * allocate SVs).
 480  */
 481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 482 char *
 483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 484 {
 485     const char *cp1;
 486     static char *__my_getenv_eqv = NULL;
 487     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 488     unsigned long int idx = 0;
 489     int trnsuccess, success, secure, saverr, savvmserr;
 490     int midx, flags;
 491     SV *tmpsv;
 492
 493     midx = my_maxidx(lnm) + 1;
 494
 495     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 496       /* Set up a temporary buffer for the return value; Perl will
 497        * clean it up at the next statement transition */
 498       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 499       if (!tmpsv) return NULL;
 500       eqv = SvPVX(tmpsv);
 501     }
 502     else {
 503       /* Assume no interpreter ==> single thread */
 504       if (__my_getenv_eqv != NULL) {
 505         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 506       }
 507       else {
 508         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 509       }
 510       eqv = __my_getenv_eqv;
 511     }
 512
 513     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 514     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 515       int len;
 516       getcwd(eqv,LNM$C_NAMLENGTH);
 517
 518       len = strlen(eqv);
 519
 520       /* Get rid of "000000/ in rooted filespecs */
 521       if (len > 7) {
 522         char * zeros;
 523         zeros = strstr(eqv, "/000000/");
 524         if (zeros != NULL) {
 525           int mlen;
 526           mlen = len - (zeros - eqv) - 7;
 527           memmove(zeros, &zeros[7], mlen);
 528           len = len - 7;
 529           eqv[len] = '\0';
 530         }
 531       }
 532       return eqv;
 533     }
 534     else {
 535       /* Impose security constraints only if tainting */
 536       if (sys) {
 537         /* Impose security constraints only if tainting */
 538         secure = PL_curinterp ? PL_tainting : will_taint;
 539         saverr = errno;  savvmserr = vaxc$errno;
 540       }
 541       else {
 542         secure = 0;
 543       }
 544
 545       flags =
 546 #ifdef SECURE_INTERNAL_GETENV
 547               secure ? PERL__TRNENV_SECURE : 0
 548 #else
 549               0
 550 #endif
 551       ;
 552
 553       /* For the getenv interface we combine all the equivalence names
 554        * of a search list logical into one value to acquire a maximum
 555        * value length of 255*128 (assuming %ENV is using logicals).
 556        */
 557       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 558
 559       /* If the name contains a semicolon-delimited index, parse it
 560        * off and make sure we only retrieve the equivalence name for
 561        * that index.  */
 562       if ((cp2 = strchr(lnm,';')) != NULL) {
 563         strcpy(uplnm,lnm);
 564         uplnm[cp2-lnm] = '\0';
 565         idx = strtoul(cp2+1,NULL,0);
 566         lnm = uplnm;
 567         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 568       }
 569
 570       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 571
 572       /* Discard NOLOGNAM on internal calls since we're often looking
 573        * for an optional name, and this "error" often shows up as the
 574        * (bogus) exit status for a die() call later on.  */
 575       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 576       return success ? eqv : Nullch;
 577     }
 578
 579 }  /* end of my_getenv() */
 580 /*}}}*/
 581
 582
 583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 584 char *
 585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 586 {
 587     const char *cp1;
 588     char *buf, *cp2;
 589     unsigned long idx = 0;
 590     int midx, flags;
 591     static char *__my_getenv_len_eqv = NULL;
 592     int secure, saverr, savvmserr;
 593     SV *tmpsv;
 594
 595     midx = my_maxidx(lnm) + 1;
 596
 597     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 598       /* Set up a temporary buffer for the return value; Perl will
 599        * clean it up at the next statement transition */
 600       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 601       if (!tmpsv) return NULL;
 602       buf = SvPVX(tmpsv);
 603     }
 604     else {
 605       /* Assume no interpreter ==> single thread */
 606       if (__my_getenv_len_eqv != NULL) {
 607         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 608       }
 609       else {
 610         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 611       }
 612       buf = __my_getenv_len_eqv;
 613     }
 614
 615     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 616     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 617     char * zeros;
 618
 619       getcwd(buf,LNM$C_NAMLENGTH);
 620       *len = strlen(buf);
 621
 622       /* Get rid of "000000/ in rooted filespecs */
 623       if (*len > 7) {
 624       zeros = strstr(buf, "/000000/");
 625       if (zeros != NULL) {
 626         int mlen;
 627         mlen = *len - (zeros - buf) - 7;
 628         memmove(zeros, &zeros[7], mlen);
 629         *len = *len - 7;
 630         buf[*len] = '\0';
 631         }
 632       }
 633       return buf;
 634     }
 635     else {
 636       if (sys) {
 637         /* Impose security constraints only if tainting */
 638         secure = PL_curinterp ? PL_tainting : will_taint;
 639         saverr = errno;  savvmserr = vaxc$errno;
 640       }
 641       else {
 642         secure = 0;
 643       }
 644
 645       flags =
 646 #ifdef SECURE_INTERNAL_GETENV
 647               secure ? PERL__TRNENV_SECURE : 0
 648 #else
 649               0
 650 #endif
 651       ;
 652
 653       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 654
 655       if ((cp2 = strchr(lnm,';')) != NULL) {
 656         strcpy(buf,lnm);
 657         buf[cp2-lnm] = '\0';
 658         idx = strtoul(cp2+1,NULL,0);
 659         lnm = buf;
 660         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 661       }
 662
 663       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 664
 665       /* Get rid of "000000/ in rooted filespecs */
 666       if (*len > 7) {
 667       char * zeros;
 668         zeros = strstr(buf, "/000000/");
 669         if (zeros != NULL) {
 670           int mlen;
 671           mlen = *len - (zeros - buf) - 7;
 672           memmove(zeros, &zeros[7], mlen);
 673           *len = *len - 7;
 674           buf[*len] = '\0';
 675         }
 676       }
 677
 678       /* Discard NOLOGNAM on internal calls since we're often looking
 679        * for an optional name, and this "error" often shows up as the
 680        * (bogus) exit status for a die() call later on.  */
 681       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 682       return *len ? buf : Nullch;
 683     }
 684
 685 }  /* end of my_getenv_len() */
 686 /*}}}*/
 687
 688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 689
 690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 691
 692 /*{{{ void prime_env_iter() */
 693 void
 694 prime_env_iter(void)
 695 /* Fill the %ENV associative array with all logical names we can
 696  * find, in preparation for iterating over it.
 697  */
 698 {
 699   static int primed = 0;
 700   HV *seenhv = NULL, *envhv;
 701   SV *sv = NULL;
 702   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 703   unsigned short int chan;
 704 #ifndef CLI$M_TRUSTED
 705 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 706 #endif
 707   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 708   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 709   long int i;
 710   bool have_sym = FALSE, have_lnm = FALSE;
 711   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 712   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 713   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 714   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 715   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 716 #if defined(PERL_IMPLICIT_CONTEXT)
 717   pTHX;
 718 #endif
 719 #if defined(USE_ITHREADS)
 720   static perl_mutex primenv_mutex;
 721   MUTEX_INIT(&primenv_mutex);
 722 #endif
 723
 724 #if defined(PERL_IMPLICIT_CONTEXT)
 725     /* We jump through these hoops because we can be called at */
 726     /* platform-specific initialization time, which is before anything is */
 727     /* set up--we can't even do a plain dTHX since that relies on the */
 728     /* interpreter structure to be initialized */
 729     if (PL_curinterp) {
 730       aTHX = PERL_GET_INTERP;
 731     } else {
 732       aTHX = NULL;
 733     }
 734 #endif
 735
 736   if (primed || !PL_envgv) return;
 737   MUTEX_LOCK(&primenv_mutex);
 738   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 739   envhv = GvHVn(PL_envgv);
 740   /* Perform a dummy fetch as an lval to insure that the hash table is
 741    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 742   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 743
 744   for (i = 0; env_tables[i]; i++) {
 745      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 746          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 747      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 748   }
 749   if (have_sym || have_lnm) {
 750     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 751     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 752     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 753     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 754   }
 755
 756   for (i--; i >= 0; i--) {
 757     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 758       char *start;
 759       int j;
 760       for (j = 0; environ[j]; j++) {
 761         if (!(start = strchr(environ[j],'='))) {
 762           if (ckWARN(WARN_INTERNAL))
 763             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 764         }
 765         else {
 766           start++;
 767           sv = newSVpv(start,0);
 768           SvTAINTED_on(sv);
 769           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 770         }
 771       }
 772       continue;
 773     }
 774     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 775              !str$case_blind_compare(&tmpdsc,&clisym)) {
 776       strcpy(cmd,"Show Symbol/Global *");
 777       cmddsc.dsc$w_length = 20;
 778       if (env_tables[i]->dsc$w_length == 12 &&
 779           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 780           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 781       flags = defflags | CLI$M_NOLOGNAM;
 782     }
 783     else {
 784       strcpy(cmd,"Show Logical *");
 785       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 786         strcat(cmd," /Table=");
 787         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 788         cmddsc.dsc$w_length = strlen(cmd);
 789       }
 790       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 791       flags = defflags | CLI$M_NOCLISYM;
 792     }
 793
 794     /* Create a new subprocess to execute each command, to exclude the
 795      * remote possibility that someone could subvert a mbx or file used
 796      * to write multiple commands to a single subprocess.
 797      */
 798     do {
 799       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 800                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 801       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 802       defflags &= ~CLI$M_TRUSTED;
 803     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 804     _ckvmssts(retsts);
 805     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 806     if (seenhv) SvREFCNT_dec(seenhv);
 807     seenhv = newHV();
 808     while (1) {
 809       char *cp1, *cp2, *key;
 810       unsigned long int sts, iosb[2], retlen, keylen;
 811       register U32 hash;
 812
 813       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 814       if (sts & 1) sts = iosb[0] & 0xffff;
 815       if (sts == SS$_ENDOFFILE) {
 816         int wakect = 0;
 817         while (substs == 0) { sys$hiber(); wakect++;}
 818         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 819         _ckvmssts(substs);
 820         break;
 821       }
 822       _ckvmssts(sts);
 823       retlen = iosb[0] >> 16;
 824       if (!retlen) continue;  /* blank line */
 825       buf[retlen] = '\0';
 826       if (iosb[1] != subpid) {
 827         if (iosb[1]) {
 828           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 829         }
 830         continue;
 831       }
 832       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 833         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 834
 835       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 836       if (*cp1 == '(' || /* Logical name table name */
 837           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 838       if (*cp1 == '"') cp1++;
 839       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 840       key = cp1;  keylen = cp2 - cp1;
 841       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 842       while (*cp2 && *cp2 != '=') cp2++;
 843       while (*cp2 && *cp2 == '=') cp2++;
 844       while (*cp2 && *cp2 == ' ') cp2++;
 845       if (*cp2 == '"') {  /* String translation; may embed "" */
 846         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 847         cp2++;  cp1--; /* Skip "" surrounding translation */
 848       }
 849       else {  /* Numeric translation */
 850         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 851         cp1--;  /* stop on last non-space char */
 852       }
 853       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 854         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 855         continue;
 856       }
 857       PERL_HASH(hash,key,keylen);
 858
 859       if (cp1 == cp2 && *cp2 == '.') {
 860         /* A single dot usually means an unprintable character, such as a null
 861          * to indicate a zero-length value.  Get the actual value to make sure.
 862          */
 863         char lnm[LNM$C_NAMLENGTH+1];
 864         char eqv[MAX_DCL_SYMBOL+1];
 865         strncpy(lnm, key, keylen);
 866         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 867         sv = newSVpvn(eqv, strlen(eqv));
 868       }
 869       else {
 870         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 871       }
 872
 873       SvTAINTED_on(sv);
 874       hv_store(envhv,key,keylen,sv,hash);
 875       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 876     }
 877     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 878       /* get the PPFs for this process, not the subprocess */
 879       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 880       char eqv[LNM$C_NAMLENGTH+1];
 881       int trnlen, i;
 882       for (i = 0; ppfs[i]; i++) {
 883         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 884         sv = newSVpv(eqv,trnlen);
 885         SvTAINTED_on(sv);
 886         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 887       }
 888     }
 889   }
 890   primed = 1;
 891   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 892   if (buf) Safefree(buf);
 893   if (seenhv) SvREFCNT_dec(seenhv);
 894   MUTEX_UNLOCK(&primenv_mutex);
 895   return;
 896
 897 }  /* end of prime_env_iter */
 898 /*}}}*/
 899
 900
 901 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 902 /* Define or delete an element in the same "environment" as
 903  * vmstrnenv().  If an element is to be deleted, it's removed from
 904  * the first place it's found.  If it's to be set, it's set in the
 905  * place designated by the first element of the table vector.
 906  * Like setenv() returns 0 for success, non-zero on error.
 907  */
 908 int
 909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 910 {
 911     const char *cp1;
 912     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 913     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 914     int nseg = 0, j;
 915     unsigned long int retsts, usermode = PSL$C_USER;
 916     struct itmlst_3 *ile, *ilist;
 917     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 918                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 921     $DESCRIPTOR(local,"_LOCAL");
 922
 923     if (!lnm) {
 924         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 925         return SS$_IVLOGNAM;
 926     }
 927
 928     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 929       *cp2 = _toupper(*cp1);
 930       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 931         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 932         return SS$_IVLOGNAM;
 933       }
 934     }
 935     lnmdsc.dsc$w_length = cp1 - lnm;
 936     if (!tabvec || !*tabvec) tabvec = env_tables;
 937
 938     if (!eqv) {  /* we're deleting n element */
 939       for (curtab = 0; tabvec[curtab]; curtab++) {
 940         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 941         int i;
 942           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 943             if ((cp1 = strchr(environ[i],'=')) &&
 944                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 945                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 946 #ifdef HAS_SETENV
 947               return setenv(lnm,"",1) ? vaxc$errno : 0;
 948             }
 949           }
 950           ivenv = 1; retsts = SS$_NOLOGNAM;
 951 #else
 952               if (ckWARN(WARN_INTERNAL))
 953                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 954               ivenv = 1; retsts = SS$_NOSUCHPGM;
 955               break;
 956             }
 957           }
 958 #endif
 959         }
 960         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 961                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 962           unsigned int symtype;
 963           if (tabvec[curtab]->dsc$w_length == 12 &&
 964               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 965               !str$case_blind_compare(&tmpdsc,&local))
 966             symtype = LIB$K_CLI_LOCAL_SYM;
 967           else symtype = LIB$K_CLI_GLOBAL_SYM;
 968           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 969           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 970           if (retsts == LIB$_NOSUCHSYM) continue;
 971           break;
 972         }
 973         else if (!ivlnm) {
 974           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 975           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 976           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 977           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 978           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 979         }
 980       }
 981     }
 982     else {  /* we're defining a value */
 983       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 984 #ifdef HAS_SETENV
 985         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 986 #else
 987         if (ckWARN(WARN_INTERNAL))
 988           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 989         retsts = SS$_NOSUCHPGM;
 990 #endif
 991       }
 992       else {
 993         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 994         eqvdsc.dsc$w_length  = strlen(eqv);
 995         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 996             !str$case_blind_compare(&tmpdsc,&clisym)) {
 997           unsigned int symtype;
 998           if (tabvec[0]->dsc$w_length == 12 &&
 999               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000                !str$case_blind_compare(&tmpdsc,&local))
1001             symtype = LIB$K_CLI_LOCAL_SYM;
1002           else symtype = LIB$K_CLI_GLOBAL_SYM;
1003           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1004         }
1005         else {
1006           if (!*eqv) eqvdsc.dsc$w_length = 1;
1007           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1008
1009             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1015             }
1016
1017             Newx(ilist,nseg+1,struct itmlst_3);
1018             ile = ilist;
1019             if (!ile) {
1020               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1021               return SS$_INSFMEM;
1022             }
1023             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1024
1025             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026               ile->itmcode = LNM$_STRING;
1027               ile->bufadr = c;
1028               if ((j+1) == nseg) {
1029                 ile->buflen = strlen(c);
1030                 /* in case we are truncating one that's too long */
1031                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1032               }
1033               else {
1034                 ile->buflen = LNM$C_NAMLENGTH;
1035               }
1036             }
1037
1038             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1039             Safefree (ilist);
1040           }
1041           else {
1042             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1043           }
1044         }
1045       }
1046     }
1047     if (!(retsts & 1)) {
1048       switch (retsts) {
1049         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051           set_errno(EVMSERR); break;
1052         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054           set_errno(EINVAL); break;
1055         case SS$_NOPRIV:
1056           set_errno(EACCES);
1057         default:
1058           _ckvmssts(retsts);
1059           set_errno(EVMSERR);
1060        }
1061        set_vaxc_errno(retsts);
1062        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1063     }
1064     else {
1065       /* We reset error values on success because Perl does an hv_fetch()
1066        * before each hv_store(), and if the thing we're setting didn't
1067        * previously exist, we've got a leftover error message.  (Of course,
1068        * this fails in the face of
1069        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070        * in that the error reported in $! isn't spurious,
1071        * but it's right more often than not.)
1072        */
1073       set_errno(0); set_vaxc_errno(retsts);
1074       return 0;
1075     }
1076
1077 }  /* end of vmssetenv() */
1078 /*}}}*/
1079
1080 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1082 void
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1084 {
1085     if (lnm && *lnm) {
1086       int len = strlen(lnm);
1087       if  (len == 7) {
1088         char uplnm[8];
1089         int i;
1090         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091         if (!strcmp(uplnm,"DEFAULT")) {
1092           if (eqv && *eqv) my_chdir(eqv);
1093           return;
1094         }
1095     }
1096 #ifndef RTL_USES_UTC
1097     if (len == 6 || len == 2) {
1098       char uplnm[7];
1099       int i;
1100       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1101       uplnm[len] = '\0';
1102       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1104     }
1105 #endif
1106   }
1107   (void) vmssetenv(lnm,eqv,NULL);
1108 }
1109 /*}}}*/
1110
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1112 /*  vmssetuserlnm
1113  *  sets a user-mode logical in the process logical name table
1114  *  used for redirection of sys$error
1115  */
1116 void
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1118 {
1119     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121     unsigned long int iss, attr = LNM$M_CONFINE;
1122     unsigned char acmode = PSL$C_USER;
1123     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1124                                  {0, 0, 0, 0}};
1125     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126     d_name.dsc$w_length = strlen(name);
1127
1128     lnmlst[0].buflen = strlen(eqv);
1129     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1130
1131     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132     if (!(iss&1)) lib$signal(iss);
1133 }
1134 /*}}}*/
1135
1136
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139  * my_crypt() provides an interface compatible with the Unix crypt()
1140  * C library function, and uses sys$hash_password() to perform VMS
1141  * password hashing.  The quadword hashed password value is returned
1142  * as a NUL-terminated 8 character string.  my_crypt() does not change
1143  * the case of its string arguments; in order to match the behavior
1144  * of LOGINOUT et al., alphabetic characters in both arguments must
1145  *  be upcased by the caller.
1146  *
1147  * - fix me to call ACM services when available
1148  */
1149 char *
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1151 {
1152 #   ifndef UAI$C_PREFERRED_ALGORITHM
1153 #     define UAI$C_PREFERRED_ALGORITHM 127
1154 #   endif
1155     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156     unsigned short int salt = 0;
1157     unsigned long int sts;
1158     struct const_dsc {
1159         unsigned short int dsc$w_length;
1160         unsigned char      dsc$b_type;
1161         unsigned char      dsc$b_class;
1162         const char *       dsc$a_pointer;
1163     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165     struct itmlst_3 uailst[3] = {
1166         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1167         { sizeof salt, UAI$_SALT,    &salt, 0},
1168         { 0,           0,            NULL,  NULL}};
1169     static char hash[9];
1170
1171     usrdsc.dsc$w_length = strlen(usrname);
1172     usrdsc.dsc$a_pointer = usrname;
1173     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1174       switch (sts) {
1175         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1176           set_errno(EACCES);
1177           break;
1178         case RMS$_RNF:
1179           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1180           break;
1181         default:
1182           set_errno(EVMSERR);
1183       }
1184       set_vaxc_errno(sts);
1185       if (sts != RMS$_RNF) return NULL;
1186     }
1187
1188     txtdsc.dsc$w_length = strlen(textpasswd);
1189     txtdsc.dsc$a_pointer = textpasswd;
1190     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1192     }
1193
1194     return (char *) hash;
1195
1196 }  /* end of my_crypt() */
1197 /*}}}*/
1198
1199
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1203
1204 /* fixup barenames that are directories for internal use.
1205  * There have been problems with the consistent handling of UNIX
1206  * style directory names when routines are presented with a name that
1207  * has no directory delimitors at all.  So this routine will eventually
1208  * fix the issue.
1209  */
1210 static char * fixup_bare_dirnames(const char * name)
1211 {
1212   if (decc_disable_to_vms_logname_translation) {
1213 /* fix me */
1214   }
1215   return NULL;
1216 }
1217
1218 /* mp_do_kill_file
1219  * A little hack to get around a bug in some implemenation of remove()
1220  * that do not know how to delete a directory
1221  *
1222  * Delete any file to which user has control access, regardless of whether
1223  * delete access is explicitly allowed.
1224  * Limitations: User must have write access to parent directory.
1225  *              Does not block signals or ASTs; if interrupted in midstream
1226  *              may leave file with an altered ACL.
1227  * HANDLE WITH CARE!
1228  */
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1230 static int
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1232 {
1233     char *vmsname, *rspec;
1234     char *remove_name;
1235     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1238     struct myacedef {
1239       unsigned char myace$b_length;
1240       unsigned char myace$b_type;
1241       unsigned short int myace$w_flags;
1242       unsigned long int myace$l_access;
1243       unsigned long int myace$l_ident;
1244     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1247      struct itmlst_3
1248        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1250        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1254
1255     /* Expand the input spec using RMS, since the CRTL remove() and
1256      * system services won't do this by themselves, so we may miss
1257      * a file "hiding" behind a logical name or search list. */
1258     Newx(vmsname, NAM$C_MAXRSS+1, char);
1259     if (do_tovmsspec(name,vmsname,0) == NULL) {
1260       Safefree(vmsname);
1261       return -1;
1262     }
1263
1264     if (decc_posix_compliant_pathnames) {
1265       /* In POSIX mode, we prefer to remove the UNIX name */
1266       rspec = vmsname;
1267       remove_name = (char *)name;
1268     }
1269     else {
1270       Newx(rspec, NAM$C_MAXRSS+1, char);
1271       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1272         Safefree(rspec);
1273         Safefree(vmsname);
1274         return -1;
1275       }
1276       Safefree(vmsname);
1277       remove_name = rspec;
1278     }
1279
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1281     if (dirflag != 0) {
1282         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283           Newx(remove_name, NAM$C_MAXRSS+1, char);
1284           do_pathify_dirspec(name, remove_name, 0);
1285           if (!rmdir(remove_name)) {
1286
1287             Safefree(remove_name);
1288             Safefree(rspec);
1289             return 0;   /* Can we just get rid of it? */
1290           }
1291         }
1292         else {
1293           if (!rmdir(remove_name)) {
1294             Safefree(rspec);
1295             return 0;   /* Can we just get rid of it? */
1296           }
1297         }
1298     }
1299     else
1300 #endif
1301       if (!remove(remove_name)) {
1302         Safefree(rspec);
1303         return 0;   /* Can we just get rid of it? */
1304       }
1305
1306     /* If not, can changing protections help? */
1307     if (vaxc$errno != RMS$_PRV) {
1308       Safefree(rspec);
1309       return -1;
1310     }
1311
1312     /* No, so we get our own UIC to use as a rights identifier,
1313      * and the insert an ACE at the head of the ACL which allows us
1314      * to delete the file.
1315      */
1316     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317     fildsc.dsc$w_length = strlen(rspec);
1318     fildsc.dsc$a_pointer = rspec;
1319     cxt = 0;
1320     newace.myace$l_ident = oldace.myace$l_ident;
1321     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1322       switch (aclsts) {
1323         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324           set_errno(ENOENT); break;
1325         case RMS$_DIR:
1326           set_errno(ENOTDIR); break;
1327         case RMS$_DEV:
1328           set_errno(ENODEV); break;
1329         case RMS$_SYN: case SS$_INVFILFOROP:
1330           set_errno(EINVAL); break;
1331         case RMS$_PRV:
1332           set_errno(EACCES); break;
1333         default:
1334           _ckvmssts(aclsts);
1335       }
1336       set_vaxc_errno(aclsts);
1337       Safefree(rspec);
1338       return -1;
1339     }
1340     /* Grab any existing ACEs with this identifier in case we fail */
1341     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343                     || fndsts == SS$_NOMOREACE ) {
1344       /* Add the new ACE . . . */
1345       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1346         goto yourroom;
1347
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1349       if (dirflag != 0)
1350         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351           Newx(remove_name, NAM$C_MAXRSS+1, char);
1352           do_pathify_dirspec(name, remove_name, 0);
1353           rmsts = rmdir(remove_name);
1354           Safefree(remove_name);
1355         }
1356         else {
1357         rmsts = rmdir(remove_name);
1358         }
1359       else
1360 #endif
1361         rmsts = remove(remove_name);
1362       if (rmsts) {
1363         /* We blew it - dir with files in it, no write priv for
1364          * parent directory, etc.  Put things back the way they were. */
1365         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1366           goto yourroom;
1367         if (fndsts & 1) {
1368           addlst[0].bufadr = &oldace;
1369           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1370             goto yourroom;
1371         }
1372       }
1373     }
1374
1375     yourroom:
1376     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377     /* We just deleted it, so of course it's not there.  Some versions of
1378      * VMS seem to return success on the unlock operation anyhow (after all
1379      * the unlock is successful), but others don't.
1380      */
1381     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382     if (aclsts & 1) aclsts = fndsts;
1383     if (!(aclsts & 1)) {
1384       set_errno(EVMSERR);
1385       set_vaxc_errno(aclsts);
1386       Safefree(rspec);
1387       return -1;
1388     }
1389
1390     Safefree(rspec);
1391     return rmsts;
1392
1393 }  /* end of kill_file() */
1394 /*}}}*/
1395
1396
1397 /*{{{int do_rmdir(char *name)*/
1398 int
1399 Perl_do_rmdir(pTHX_ const char *name)
1400 {
1401     char dirfile[NAM$C_MAXRSS+1];
1402     int retval;
1403     Stat_t st;
1404
1405     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1408     return retval;
1409
1410 }  /* end of do_rmdir */
1411 /*}}}*/
1412
1413 /* kill_file
1414  * Delete any file to which user has control access, regardless of whether
1415  * delete access is explicitly allowed.
1416  * Limitations: User must have write access to parent directory.
1417  *              Does not block signals or ASTs; if interrupted in midstream
1418  *              may leave file with an altered ACL.
1419  * HANDLE WITH CARE!
1420  */
1421 /*{{{int kill_file(char *name)*/
1422 int
1423 Perl_kill_file(pTHX_ const char *name)
1424 {
1425     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1429     struct myacedef {
1430       unsigned char myace$b_length;
1431       unsigned char myace$b_type;
1432       unsigned short int myace$w_flags;
1433       unsigned long int myace$l_access;
1434       unsigned long int myace$l_ident;
1435     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1438      struct itmlst_3
1439        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1441        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1445
1446     /* Expand the input spec using RMS, since the CRTL remove() and
1447      * system services won't do this by themselves, so we may miss
1448      * a file "hiding" behind a logical name or search list. */
1449     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1452     /* If not, can changing protections help? */
1453     if (vaxc$errno != RMS$_PRV) return -1;
1454
1455     /* No, so we get our own UIC to use as a rights identifier,
1456      * and the insert an ACE at the head of the ACL which allows us
1457      * to delete the file.
1458      */
1459     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460     fildsc.dsc$w_length = strlen(rspec);
1461     fildsc.dsc$a_pointer = rspec;
1462     cxt = 0;
1463     newace.myace$l_ident = oldace.myace$l_ident;
1464     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1465       switch (aclsts) {
1466         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467           set_errno(ENOENT); break;
1468         case RMS$_DIR:
1469           set_errno(ENOTDIR); break;
1470         case RMS$_DEV:
1471           set_errno(ENODEV); break;
1472         case RMS$_SYN: case SS$_INVFILFOROP:
1473           set_errno(EINVAL); break;
1474         case RMS$_PRV:
1475           set_errno(EACCES); break;
1476         default:
1477           _ckvmssts(aclsts);
1478       }
1479       set_vaxc_errno(aclsts);
1480       return -1;
1481     }
1482     /* Grab any existing ACEs with this identifier in case we fail */
1483     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485                     || fndsts == SS$_NOMOREACE ) {
1486       /* Add the new ACE . . . */
1487       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1488         goto yourroom;
1489       if ((rmsts = remove(name))) {
1490         /* We blew it - dir with files in it, no write priv for
1491          * parent directory, etc.  Put things back the way they were. */
1492         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1493           goto yourroom;
1494         if (fndsts & 1) {
1495           addlst[0].bufadr = &oldace;
1496           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1497             goto yourroom;
1498         }
1499       }
1500     }
1501
1502     yourroom:
1503     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504     /* We just deleted it, so of course it's not there.  Some versions of
1505      * VMS seem to return success on the unlock operation anyhow (after all
1506      * the unlock is successful), but others don't.
1507      */
1508     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509     if (aclsts & 1) aclsts = fndsts;
1510     if (!(aclsts & 1)) {
1511       set_errno(EVMSERR);
1512       set_vaxc_errno(aclsts);
1513       return -1;
1514     }
1515
1516     return rmsts;
1517
1518 }  /* end of kill_file() */
1519 /*}}}*/
1520
1521
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1523 int
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1525 {
1526   STRLEN dirlen = strlen(dir);
1527
1528   /* zero length string sometimes gives ACCVIO */
1529   if (dirlen == 0) return -1;
1530
1531   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532    * null file name/type.  However, it's commonplace under Unix,
1533    * so we'll allow it for a gain in portability.
1534    */
1535   if (dir[dirlen-1] == '/') {
1536     char *newdir = savepvn(dir,dirlen-1);
1537     int ret = mkdir(newdir,mode);
1538     Safefree(newdir);
1539     return ret;
1540   }
1541   else return mkdir(dir,mode);
1542 }  /* end of my_mkdir */
1543 /*}}}*/
1544
1545 /*{{{int my_chdir(char *)*/
1546 int
1547 Perl_my_chdir(pTHX_ const char *dir)
1548 {
1549   STRLEN dirlen = strlen(dir);
1550
1551   /* zero length string sometimes gives ACCVIO */
1552   if (dirlen == 0) return -1;
1553   const char *dir1;
1554
1555   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1557    * so that existing scripts do not need to be changed.
1558    */
1559   dir1 = dir;
1560   while ((dirlen > 0) && (*dir1 == ' ')) {
1561     dir1++;
1562     dirlen--;
1563   }
1564
1565   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1566    * that implies
1567    * null file name/type.  However, it's commonplace under Unix,
1568    * so we'll allow it for a gain in portability.
1569    *
1570    * - Preview- '/' will be valid soon on VMS
1571    */
1572   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573     char *newdir = savepvn(dir,dirlen-1);
1574     int ret = chdir(newdir);
1575     Safefree(newdir);
1576     return ret;
1577   }
1578   else return chdir(dir);
1579 }  /* end of my_chdir */
1580 /*}}}*/
1581
1582
1583 /*{{{FILE *my_tmpfile()*/
1584 FILE *
1585 my_tmpfile(void)
1586 {
1587   FILE *fp;
1588   char *cp;
1589
1590   if ((fp = tmpfile())) return fp;
1591
1592   Newx(cp,L_tmpnam+24,char);
1593   if (decc_filename_unix_only == 0)
1594     strcpy(cp,"Sys$Scratch:");
1595   else
1596     strcpy(cp,"/tmp/");
1597   tmpnam(cp+strlen(cp));
1598   strcat(cp,".Perltmp");
1599   fp = fopen(cp,"w+","fop=dlt");
1600   Safefree(cp);
1601   return fp;
1602 }
1603 /*}}}*/
1604
1605
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1607 /*
1608  * The C RTL's sigaction fails to check for invalid signal numbers so we
1609  * help it out a bit.  The docs are correct, but the actual routine doesn't
1610  * do what the docs say it will.
1611  */
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1613 int
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615                    struct sigaction* oact)
1616 {
1617   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618         SETERRNO(EINVAL, SS$_INVARG);
1619         return -1;
1620   }
1621   return sigaction(sig, act, oact);
1622 }
1623 /*}}}*/
1624 #endif
1625
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1628
1629 /* We implement our own kill() using the undocumented system service
1630    sys$sigprc for one of two reasons:
1631
1632    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633    target process to do a sys$exit, which usually can't be handled
1634    gracefully...certainly not by Perl and the %SIG{} mechanism.
1635
1636    2.) If the kill() in the CRTL can't be called from a signal
1637    handler without disappearing into the ether, i.e., the signal
1638    it purportedly sends is never trapped. Still true as of VMS 7.3.
1639
1640    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641    in the target process rather than calling sys$exit.
1642
1643    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1646    with condition codes C$_SIG0+nsig*8, catching the exception on the
1647    target process and resignaling with appropriate arguments.
1648
1649    But we don't have that VMS 7.0+ exception handler, so if you
1650    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1651
1652    Also note that SIGTERM is listed in the docs as being "unimplemented",
1653    yet always seems to be signaled with a VMS condition code of 4 (and
1654    correctly handled for that code).  So we hardwire it in.
1655
1656    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1658    than signalling with an unrecognized (and unhandled by CRTL) code.
1659 */
1660
1661 #define _MY_SIG_MAX 17
1662
1663 unsigned int
1664 Perl_sig_to_vmscondition(int sig)
1665 {
1666     static unsigned int sig_code[_MY_SIG_MAX+1] =
1667     {
1668         0,                  /*  0 ZERO     */
1669         SS$_HANGUP,         /*  1 SIGHUP   */
1670         SS$_CONTROLC,       /*  2 SIGINT   */
1671         SS$_CONTROLY,       /*  3 SIGQUIT  */
1672         SS$_RADRMOD,        /*  4 SIGILL   */
1673         SS$_BREAK,          /*  5 SIGTRAP  */
1674         SS$_OPCCUS,         /*  6 SIGABRT  */
1675         SS$_COMPAT,         /*  7 SIGEMT   */
1676 #ifdef __VAX
1677         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1678 #else
1679         SS$_HPARITH,        /*  8 SIGFPE AXP */
1680 #endif
1681         SS$_ABORT,          /*  9 SIGKILL  */
1682         SS$_ACCVIO,         /* 10 SIGBUS   */
1683         SS$_ACCVIO,         /* 11 SIGSEGV  */
1684         SS$_BADPARAM,       /* 12 SIGSYS   */
1685         SS$_NOMBX,          /* 13 SIGPIPE  */
1686         SS$_ASTFLT,         /* 14 SIGALRM  */
1687         4,                  /* 15 SIGTERM  */
1688         0,                  /* 16 SIGUSR1  */
1689         0                   /* 17 SIGUSR2  */
1690     };
1691
1692 #if __VMS_VER >= 60200000
1693     static int initted = 0;
1694     if (!initted) {
1695         initted = 1;
1696         sig_code[16] = C$_SIGUSR1;
1697         sig_code[17] = C$_SIGUSR2;
1698     }
1699 #endif
1700
1701     if (sig < _SIG_MIN) return 0;
1702     if (sig > _MY_SIG_MAX) return 0;
1703     return sig_code[sig];
1704 }
1705
1706 int
1707 Perl_my_kill(int pid, int sig)
1708 {
1709     dTHX;
1710     int iss;
1711     unsigned int code;
1712     int sys$sigprc(unsigned int *pidadr,
1713                      struct dsc$descriptor_s *prcname,
1714                      unsigned int code);
1715
1716      /* sig 0 means validate the PID */
1717     /*------------------------------*/
1718     if (sig == 0) {
1719         const unsigned long int jpicode = JPI$_PID;
1720         pid_t ret_pid;
1721         int status;
1722         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723         if ($VMS_STATUS_SUCCESS(status))
1724            return 0;
1725         switch (status) {
1726         case SS$_NOSUCHNODE:
1727         case SS$_UNREACHABLE:
1728         case SS$_NONEXPR:
1729            errno = ESRCH;
1730            break;
1731         case SS$_NOPRIV:
1732            errno = EPERM;
1733            break;
1734         default:
1735            errno = EVMSERR;
1736         }
1737         vaxc$errno=status;
1738         return -1;
1739     }
1740
1741     code = Perl_sig_to_vmscondition(sig);
1742
1743     if (!code) {
1744         SETERRNO(EINVAL, SS$_BADPARAM);
1745         return -1;
1746     }
1747
1748     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749      * signals are to be sent to multiple processes.
1750      *  pid = 0 - all processes in group except ones that the system exempts
1751      *  pid = -1 - all processes except ones that the system exempts
1752      *  pid = -n - all processes in group (abs(n)) except ...
1753      * For now, just report as not supported.
1754      */
1755
1756     if (pid <= 0) {
1757         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1758         return -1;
1759     }
1760
1761     iss = sys$sigprc((unsigned int *)&pid,0,code);
1762     if (iss&1) return 0;
1763
1764     switch (iss) {
1765       case SS$_NOPRIV:
1766         set_errno(EPERM);  break;
1767       case SS$_NONEXPR:
1768       case SS$_NOSUCHNODE:
1769       case SS$_UNREACHABLE:
1770         set_errno(ESRCH);  break;
1771       case SS$_INSFMEM:
1772         set_errno(ENOMEM); break;
1773       default:
1774         _ckvmssts(iss);
1775         set_errno(EVMSERR);
1776     }
1777     set_vaxc_errno(iss);
1778
1779     return -1;
1780 }
1781 #endif
1782
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1785 ** existing code.
1786 **
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1788 ** success.
1789 **
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1792 **
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1794 ** decoding.
1795 */
1796
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1799 #endif
1800 #ifndef DCL_IVVERB
1801 #define DCL_IVVERB 0x38090
1802 #endif
1803
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1805 {
1806 int facility;
1807 int fac_sp;
1808 int msg_no;
1809 int msg_status;
1810 int unix_status;
1811
1812   /* Assume the best or the worst */
1813   if (vms_status & STS$M_SUCCESS)
1814     unix_status = 0;
1815   else
1816     unix_status = EVMSERR;
1817
1818   msg_status = vms_status & ~STS$M_CONTROL;
1819
1820   facility = vms_status & STS$M_FAC_NO;
1821   fac_sp = vms_status & STS$M_FAC_SP;
1822   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1823
1824   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1825     switch(msg_no) {
1826     case SS$_NORMAL:
1827         unix_status = 0;
1828         break;
1829     case SS$_ACCVIO:
1830         unix_status = EFAULT;
1831         break;
1832     case SS$_DEVOFFLINE:
1833         unix_status = EBUSY;
1834         break;
1835     case SS$_CLEARED:
1836         unix_status = ENOTCONN;
1837         break;
1838     case SS$_IVCHAN:
1839     case SS$_IVLOGNAM:
1840     case SS$_BADPARAM:
1841     case SS$_IVLOGTAB:
1842     case SS$_NOLOGNAM:
1843     case SS$_NOLOGTAB:
1844     case SS$_INVFILFOROP:
1845     case SS$_INVARG:
1846     case SS$_NOSUCHID:
1847     case SS$_IVIDENT:
1848         unix_status = EINVAL;
1849         break;
1850     case SS$_UNSUPPORTED:
1851         unix_status = ENOTSUP;
1852         break;
1853     case SS$_FILACCERR:
1854     case SS$_NOGRPPRV:
1855     case SS$_NOSYSPRV:
1856         unix_status = EACCES;
1857         break;
1858     case SS$_DEVICEFULL:
1859         unix_status = ENOSPC;
1860         break;
1861     case SS$_NOSUCHDEV:
1862         unix_status = ENODEV;
1863         break;
1864     case SS$_NOSUCHFILE:
1865     case SS$_NOSUCHOBJECT:
1866         unix_status = ENOENT;
1867         break;
1868     case SS$_ABORT:                                 /* Fatal case */
1869     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871         unix_status = EINTR;
1872         break;
1873     case SS$_BUFFEROVF:
1874         unix_status = E2BIG;
1875         break;
1876     case SS$_INSFMEM:
1877         unix_status = ENOMEM;
1878         break;
1879     case SS$_NOPRIV:
1880         unix_status = EPERM;
1881         break;
1882     case SS$_NOSUCHNODE:
1883     case SS$_UNREACHABLE:
1884         unix_status = ESRCH;
1885         break;
1886     case SS$_NONEXPR:
1887         unix_status = ECHILD;
1888         break;
1889     default:
1890         if ((facility == 0) && (msg_no < 8)) {
1891           /* These are not real VMS status codes so assume that they are
1892           ** already UNIX status codes
1893           */
1894           unix_status = msg_no;
1895           break;
1896         }
1897     }
1898   }
1899   else {
1900     /* Translate a POSIX exit code to a UNIX exit code */
1901     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1902         unix_status = (msg_no & 0x07F8) >> 3;
1903     }
1904     else {
1905
1906          /* Documented traditional behavior for handling VMS child exits */
1907         /*--------------------------------------------------------------*/
1908         if (child_flag != 0) {
1909
1910              /* Success / Informational return 0 */
1911             /*----------------------------------*/
1912             if (msg_no & STS$K_SUCCESS)
1913                 return 0;
1914
1915              /* Warning returns 1 */
1916             /*-------------------*/
1917             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1918                 return 1;
1919
1920              /* Everything else pass through the severity bits */
1921             /*------------------------------------------------*/
1922             return (msg_no & STS$M_SEVERITY);
1923         }
1924
1925          /* Normal VMS status to ERRNO mapping attempt */
1926         /*--------------------------------------------*/
1927         switch(msg_status) {
1928         /* case RMS$_EOF: */ /* End of File */
1929         case RMS$_FNF:  /* File Not Found */
1930         case RMS$_DNF:  /* Dir Not Found */
1931                 unix_status = ENOENT;
1932                 break;
1933         case RMS$_RNF:  /* Record Not Found */
1934                 unix_status = ESRCH;
1935                 break;
1936         case RMS$_DIR:
1937                 unix_status = ENOTDIR;
1938                 break;
1939         case RMS$_DEV:
1940                 unix_status = ENODEV;
1941                 break;
1942         case RMS$_IFI:
1943         case RMS$_FAC:
1944         case RMS$_ISI:
1945                 unix_status = EBADF;
1946                 break;
1947         case RMS$_FEX:
1948                 unix_status = EEXIST;
1949                 break;
1950         case RMS$_SYN:
1951         case RMS$_FNM:
1952         case LIB$_INVSTRDES:
1953         case LIB$_INVARG:
1954         case LIB$_NOSUCHSYM:
1955         case LIB$_INVSYMNAM:
1956         case DCL_IVVERB:
1957                 unix_status = EINVAL;
1958                 break;
1959         case CLI$_BUFOVF:
1960         case RMS$_RTB:
1961         case CLI$_TKNOVF:
1962         case CLI$_RSLOVF:
1963                 unix_status = E2BIG;
1964                 break;
1965         case RMS$_PRV:  /* No privilege */
1966         case RMS$_ACC:  /* ACP file access failed */
1967         case RMS$_WLK:  /* Device write locked */
1968                 unix_status = EACCES;
1969                 break;
1970         /* case RMS$_NMF: */  /* No more files */
1971         }
1972     }
1973   }
1974
1975   return unix_status;
1976 }
1977
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979  * value.  This is hard to do as there could be many possible VMS
1980  * error statuses that caused the errno value to be set.
1981  */
1982
1983 int Perl_unix_status_to_vms(int unix_status)
1984 {
1985 int test_unix_status;
1986
1987      /* Trivial cases first */
1988     /*---------------------*/
1989     if (unix_status == EVMSERR)
1990         return vaxc$errno;
1991
1992      /* Is vaxc$errno sane? */
1993     /*---------------------*/
1994     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995     if (test_unix_status == unix_status)
1996         return vaxc$errno;
1997
1998      /* If way out of range, must be VMS code already */
1999     /*-----------------------------------------------*/
2000     if (unix_status > EVMSERR)
2001         return unix_status;
2002
2003      /* If out of range, punt */
2004     /*-----------------------*/
2005     if (unix_status > __ERRNO_MAX)
2006         return SS$_ABORT;
2007
2008
2009      /* Ok, now we have to do it the hard way. */
2010     /*----------------------------------------*/
2011     switch(unix_status) {
2012     case 0:     return SS$_NORMAL;
2013     case EPERM: return SS$_NOPRIV;
2014     case ENOENT: return SS$_NOSUCHOBJECT;
2015     case ESRCH: return SS$_UNREACHABLE;
2016     case EINTR: return SS$_ABORT;
2017     /* case EIO: */
2018     /* case ENXIO:  */
2019     case E2BIG: return SS$_BUFFEROVF;
2020     /* case ENOEXEC */
2021     case EBADF: return RMS$_IFI;
2022     case ECHILD: return SS$_NONEXPR;
2023     /* case EAGAIN */
2024     case ENOMEM: return SS$_INSFMEM;
2025     case EACCES: return SS$_FILACCERR;
2026     case EFAULT: return SS$_ACCVIO;
2027     /* case ENOTBLK */
2028     case EBUSY: return SS$_DEVOFFLINE;
2029     case EEXIST: return RMS$_FEX;
2030     /* case EXDEV */
2031     case ENODEV: return SS$_NOSUCHDEV;
2032     case ENOTDIR: return RMS$_DIR;
2033     /* case EISDIR */
2034     case EINVAL: return SS$_INVARG;
2035     /* case ENFILE */
2036     /* case EMFILE */
2037     /* case ENOTTY */
2038     /* case ETXTBSY */
2039     /* case EFBIG */
2040     case ENOSPC: return SS$_DEVICEFULL;
2041     case ESPIPE: return LIB$_INVARG;
2042     /* case EROFS: */
2043     /* case EMLINK: */
2044     /* case EPIPE: */
2045     /* case EDOM */
2046     case ERANGE: return LIB$_INVARG;
2047     /* case EWOULDBLOCK */
2048     /* case EINPROGRESS */
2049     /* case EALREADY */
2050     /* case ENOTSOCK */
2051     /* case EDESTADDRREQ */
2052     /* case EMSGSIZE */
2053     /* case EPROTOTYPE */
2054     /* case ENOPROTOOPT */
2055     /* case EPROTONOSUPPORT */
2056     /* case ESOCKTNOSUPPORT */
2057     /* case EOPNOTSUPP */
2058     /* case EPFNOSUPPORT */
2059     /* case EAFNOSUPPORT */
2060     /* case EADDRINUSE */
2061     /* case EADDRNOTAVAIL */
2062     /* case ENETDOWN */
2063     /* case ENETUNREACH */
2064     /* case ENETRESET */
2065     /* case ECONNABORTED */
2066     /* case ECONNRESET */
2067     /* case ENOBUFS */
2068     /* case EISCONN */
2069     case ENOTCONN: return SS$_CLEARED;
2070     /* case ESHUTDOWN */
2071     /* case ETOOMANYREFS */
2072     /* case ETIMEDOUT */
2073     /* case ECONNREFUSED */
2074     /* case ELOOP */
2075     /* case ENAMETOOLONG */
2076     /* case EHOSTDOWN */
2077     /* case EHOSTUNREACH */
2078     /* case ENOTEMPTY */
2079     /* case EPROCLIM */
2080     /* case EUSERS  */
2081     /* case EDQUOT  */
2082     /* case ENOMSG  */
2083     /* case EIDRM */
2084     /* case EALIGN */
2085     /* case ESTALE */
2086     /* case EREMOTE */
2087     /* case ENOLCK */
2088     /* case ENOSYS */
2089     /* case EFTYPE */
2090     /* case ECANCELED */
2091     /* case EFAIL */
2092     /* case EINPROG */
2093     case ENOTSUP:
2094         return SS$_UNSUPPORTED;
2095     /* case EDEADLK */
2096     /* case ENWAIT */
2097     /* case EILSEQ */
2098     /* case EBADCAT */
2099     /* case EBADMSG */
2100     /* case EABANDONED */
2101     default:
2102         return SS$_ABORT; /* punt */
2103     }
2104
2105   return SS$_ABORT; /* Should not get here */
2106 }
2107
2108
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ        512
2111
2112
2113 static void
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2115 {
2116   unsigned long int mbxbufsiz;
2117   static unsigned long int syssize = 0;
2118   unsigned long int dviitm = DVI$_DEVNAM;
2119   char csize[LNM$C_NAMLENGTH+1];
2120   int sts;
2121
2122   if (!syssize) {
2123     unsigned long syiitm = SYI$_MAXBUF;
2124     /*
2125      * Get the SYSGEN parameter MAXBUF
2126      *
2127      * If the logical 'PERL_MBX_SIZE' is defined
2128      * use the value of the logical instead of PERL_BUFSIZ, but
2129      * keep the size between 128 and MAXBUF.
2130      *
2131      */
2132     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2133   }
2134
2135   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136       mbxbufsiz = atoi(csize);
2137   } else {
2138       mbxbufsiz = PERL_BUFSIZ;
2139   }
2140   if (mbxbufsiz < 128) mbxbufsiz = 128;
2141   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2142
2143   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2144
2145   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2147
2148 }  /* end of create_mbx() */
2149
2150
2151 /*{{{  my_popen and my_pclose*/
2152
2153 typedef struct _iosb           IOSB;
2154 typedef struct _iosb*         pIOSB;
2155 typedef struct _pipe           Pipe;
2156 typedef struct _pipe*         pPipe;
2157 typedef struct pipe_details    Info;
2158 typedef struct pipe_details*  pInfo;
2159 typedef struct _srqp            RQE;
2160 typedef struct _srqp*          pRQE;
2161 typedef struct _tochildbuf      CBuf;
2162 typedef struct _tochildbuf*    pCBuf;
2163
2164 struct _iosb {
2165     unsigned short status;
2166     unsigned short count;
2167     unsigned long  dvispec;
2168 };
2169
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp {          /* VMS self-relative queue entry */
2173     unsigned long qptr[2];
2174 };
2175 #pragma member_alignment restore
2176 static RQE  RQE_ZERO = {0,0};
2177
2178 struct _tochildbuf {
2179     RQE             q;
2180     int             eof;
2181     unsigned short  size;
2182     char            *buf;
2183 };
2184
2185 struct _pipe {
2186     RQE            free;
2187     RQE            wait;
2188     int            fd_out;
2189     unsigned short chan_in;
2190     unsigned short chan_out;
2191     char          *buf;
2192     unsigned int   bufsize;
2193     IOSB           iosb;
2194     IOSB           iosb2;
2195     int           *pipe_done;
2196     int            retry;
2197     int            type;
2198     int            shut_on_empty;
2199     int            need_wake;
2200     pPipe         *home;
2201     pInfo          info;
2202     pCBuf          curr;
2203     pCBuf          curr2;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205     void            *thx;           /* Either a thread or an interpreter */
2206                                     /* pointer, depending on how we're built */
2207 #endif
2208 };
2209
2210
2211 struct pipe_details
2212 {
2213     pInfo           next;
2214     PerlIO *fp;  /* file pointer to pipe mailbox */
2215     int useFILE; /* using stdio, not perlio */
2216     int pid;   /* PID of subprocess */
2217     int mode;  /* == 'r' if pipe open for reading */
2218     int done;  /* subprocess has completed */
2219     int waiting; /* waiting for completion/closure */
2220     int             closing;        /* my_pclose is closing this pipe */
2221     unsigned long   completion;     /* termination status of subprocess */
2222     pPipe           in;             /* pipe in to sub */
2223     pPipe           out;            /* pipe out of sub */
2224     pPipe           err;            /* pipe of sub's sys$error */
2225     int             in_done;        /* true when in pipe finished */
2226     int             out_done;
2227     int             err_done;
2228 };
2229
2230 struct exit_control_block
2231 {
2232     struct exit_control_block *flink;
2233     unsigned long int   (*exit_routine)();
2234     unsigned long int arg_count;
2235     unsigned long int *status_address;
2236     unsigned long int exit_status;
2237 };
2238
2239 typedef struct _closed_pipes    Xpipe;
2240 typedef struct _closed_pipes*  pXpipe;
2241
2242 struct _closed_pipes {
2243     int             pid;            /* PID of subprocess */
2244     unsigned long   completion;     /* termination status of subprocess */
2245 };
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int   closed_index = 0;
2249 static int   closed_num = 0;
2250
2251 #define RETRY_DELAY     "0 ::0.20"
2252 #define MAX_RETRY              50
2253
2254 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2257
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2260
2261 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2262
2263
2264
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2267 {
2268     pInfo info;
2269     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270     int sts, did_stuff, need_eof, j;
2271
2272     /*
2273         flush any pending i/o
2274     */
2275     info = open_pipes;
2276     while (info) {
2277         if (info->fp) {
2278            if (!info->useFILE)
2279                PerlIO_flush(info->fp);   /* first, flush data */
2280            else
2281                fflush((FILE *)info->fp);
2282         }
2283         info = info->next;
2284     }
2285
2286     /*
2287      next we try sending an EOF...ignore if doesn't work, make sure we
2288      don't hang
2289     */
2290     did_stuff = 0;
2291     info = open_pipes;
2292
2293     while (info) {
2294       int need_eof;
2295       _ckvmssts_noperl(sys$setast(0));
2296       if (info->in && !info->in->shut_on_empty) {
2297         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2298                           0, 0, 0, 0, 0, 0));
2299         info->waiting = 1;
2300         did_stuff = 1;
2301       }
2302       _ckvmssts_noperl(sys$setast(1));
2303       info = info->next;
2304     }
2305
2306     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2307
2308     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2309         int nwait = 0;
2310
2311         info = open_pipes;
2312         while (info) {
2313           _ckvmssts_noperl(sys$setast(0));
2314           if (info->waiting && info->done)
2315                 info->waiting = 0;
2316           nwait += info->waiting;
2317           _ckvmssts_noperl(sys$setast(1));
2318           info = info->next;
2319         }
2320         if (!nwait) break;
2321         sleep(1);
2322     }
2323
2324     did_stuff = 0;
2325     info = open_pipes;
2326     while (info) {
2327       _ckvmssts_noperl(sys$setast(0));
2328       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329         sts = sys$forcex(&info->pid,0,&abort);
2330         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2331         did_stuff = 1;
2332       }
2333       _ckvmssts_noperl(sys$setast(1));
2334       info = info->next;
2335     }
2336
2337     /* again, wait for effect */
2338
2339     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2340         int nwait = 0;
2341
2342         info = open_pipes;
2343         while (info) {
2344           _ckvmssts_noperl(sys$setast(0));
2345           if (info->waiting && info->done)
2346                 info->waiting = 0;
2347           nwait += info->waiting;
2348           _ckvmssts_noperl(sys$setast(1));
2349           info = info->next;
2350         }
2351         if (!nwait) break;
2352         sleep(1);
2353     }
2354
2355     info = open_pipes;
2356     while (info) {
2357       _ckvmssts_noperl(sys$setast(0));
2358       if (!info->done) {  /* We tried to be nice . . . */
2359         sts = sys$delprc(&info->pid,0);
2360         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2361       }
2362       _ckvmssts_noperl(sys$setast(1));
2363       info = info->next;
2364     }
2365
2366     while(open_pipes) {
2367       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368       else if (!(sts & 1)) retsts = sts;
2369     }
2370     return retsts;
2371 }
2372
2373 static struct exit_control_block pipe_exitblock =
2374        {(struct exit_control_block *) 0,
2375         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2376
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2380
2381 static void
2382 popen_completion_ast(pInfo info)
2383 {
2384   pInfo i = open_pipes;
2385   int iss;
2386   int sts;
2387   pXpipe x;
2388
2389   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390   closed_list[closed_index].pid = info->pid;
2391   closed_list[closed_index].completion = info->completion;
2392   closed_index++;
2393   if (closed_index == NKEEPCLOSED)
2394     closed_index = 0;
2395   closed_num++;
2396
2397   while (i) {
2398     if (i == info) break;
2399     i = i->next;
2400   }
2401   if (!i) return;       /* unlinked, probably freed too */
2402
2403   info->done = TRUE;
2404
2405 /*
2406     Writing to subprocess ...
2407             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2408
2409             chan_out may be waiting for "done" flag, or hung waiting
2410             for i/o completion to child...cancel the i/o.  This will
2411             put it into "snarf mode" (done but no EOF yet) that discards
2412             input.
2413
2414     Output from subprocess (stdout, stderr) needs to be flushed and
2415     shut down.   We try sending an EOF, but if the mbx is full the pipe
2416     routine should still catch the "shut_on_empty" flag, telling it to
2417     use immediate-style reads so that "mbx empty" -> EOF.
2418
2419
2420 */
2421   if (info->in && !info->in_done) {               /* only for mode=w */
2422         if (info->in->shut_on_empty && info->in->need_wake) {
2423             info->in->need_wake = FALSE;
2424             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2425         } else {
2426             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2427         }
2428   }
2429
2430   if (info->out && !info->out_done) {             /* were we also piping output? */
2431       info->out->shut_on_empty = TRUE;
2432       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434       _ckvmssts_noperl(iss);
2435   }
2436
2437   if (info->err && !info->err_done) {        /* we were piping stderr */
2438         info->err->shut_on_empty = TRUE;
2439         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441         _ckvmssts_noperl(iss);
2442   }
2443   _ckvmssts_noperl(sys$setef(pipe_ef));
2444
2445 }
2446
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2449
2450 /*
2451     we actually differ from vmstrnenv since we use this to
2452     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453     are pointing to the same thing
2454 */
2455
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2458 {
2459     int iss;
2460     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461     $DESCRIPTOR(d_log,"");
2462     struct _il3 {
2463         unsigned short length;
2464         unsigned short code;
2465         char *         buffer_addr;
2466         unsigned short *retlenaddr;
2467     } itmlst[2];
2468     unsigned short l, ifi;
2469
2470     d_log.dsc$a_pointer = logical;
2471     d_log.dsc$w_length  = strlen(logical);
2472
2473     itmlst[0].code = LNM$_STRING;
2474     itmlst[0].length = 255;
2475     itmlst[0].buffer_addr = result;
2476     itmlst[0].retlenaddr = &l;
2477
2478     itmlst[1].code = 0;
2479     itmlst[1].length = 0;
2480     itmlst[1].buffer_addr = 0;
2481     itmlst[1].retlenaddr = 0;
2482
2483     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484     if (iss == SS$_NOLOGNAM) {
2485         iss = SS$_NORMAL;
2486         l = 0;
2487     }
2488     if (!(iss&1)) lib$signal(iss);
2489     result[l] = '\0';
2490 /*
2491     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2492     strip it off and return the ifi, if any
2493 */
2494     ifi  = 0;
2495     if (result[0] == 0x1b && result[1] == 0x00) {
2496         memmove(&ifi,result+2,2);
2497         strcpy(result,result+4);
2498     }
2499     return ifi;     /* this is the RMS internal file id */
2500 }
2501
2502 static void pipe_infromchild_ast(pPipe p);
2503
2504 /*
2505     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506     inside an AST routine without worrying about reentrancy and which Perl
2507     memory allocator is being used.
2508
2509     We read data and queue up the buffers, then spit them out one at a
2510     time to the output mailbox when the output mailbox is ready for one.
2511
2512 */
2513 #define INITIAL_TOCHILDQUEUE  2
2514
2515 static pPipe
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2517 {
2518     pPipe p;
2519     pCBuf b;
2520     char mbx1[64], mbx2[64];
2521     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522                                       DSC$K_CLASS_S, mbx1},
2523                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524                                       DSC$K_CLASS_S, mbx2};
2525     unsigned int dviitm = DVI$_DEVBUFSIZ;
2526     int j, n;
2527
2528     n = sizeof(Pipe);
2529     _ckvmssts(lib$get_vm(&n, &p));
2530
2531     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2532     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2533     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2534
2535     p->buf           = 0;
2536     p->shut_on_empty = FALSE;
2537     p->need_wake     = FALSE;
2538     p->type          = 0;
2539     p->retry         = 0;
2540     p->iosb.status   = SS$_NORMAL;
2541     p->iosb2.status  = SS$_NORMAL;
2542     p->free          = RQE_ZERO;
2543     p->wait          = RQE_ZERO;
2544     p->curr          = 0;
2545     p->curr2         = 0;
2546     p->info          = 0;
2547 #ifdef PERL_IMPLICIT_CONTEXT
2548     p->thx           = aTHX;
2549 #endif
2550
2551     n = sizeof(CBuf) + p->bufsize;
2552
2553     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2554         _ckvmssts(lib$get_vm(&n, &b));
2555         b->buf = (char *) b + sizeof(CBuf);
2556         _ckvmssts(lib$insqhi(b, &p->free));
2557     }
2558
2559     pipe_tochild2_ast(p);
2560     pipe_tochild1_ast(p);
2561     strcpy(wmbx, mbx1);
2562     strcpy(rmbx, mbx2);
2563     return p;
2564 }
2565
2566 /*  reads the MBX Perl is writing, and queues */
2567
2568 static void
2569 pipe_tochild1_ast(pPipe p)
2570 {
2571     pCBuf b = p->curr;
2572     int iss = p->iosb.status;
2573     int eof = (iss == SS$_ENDOFFILE);
2574     int sts;
2575 #ifdef PERL_IMPLICIT_CONTEXT
2576     pTHX = p->thx;
2577 #endif
2578
2579     if (p->retry) {
2580         if (eof) {
2581             p->shut_on_empty = TRUE;
2582             b->eof     = TRUE;
2583             _ckvmssts(sys$dassgn(p->chan_in));
2584         } else  {
2585             _ckvmssts(iss);
2586         }
2587
2588         b->eof  = eof;
2589         b->size = p->iosb.count;
2590         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2591         if (p->need_wake) {
2592             p->need_wake = FALSE;
2593             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2594         }
2595     } else {
2596         p->retry = 1;   /* initial call */
2597     }
2598
2599     if (eof) {                  /* flush the free queue, return when done */
2600         int n = sizeof(CBuf) + p->bufsize;
2601         while (1) {
2602             iss = lib$remqti(&p->free, &b);
2603             if (iss == LIB$_QUEWASEMP) return;
2604             _ckvmssts(iss);
2605             _ckvmssts(lib$free_vm(&n, &b));
2606         }
2607     }
2608
2609     iss = lib$remqti(&p->free, &b);
2610     if (iss == LIB$_QUEWASEMP) {
2611         int n = sizeof(CBuf) + p->bufsize;
2612         _ckvmssts(lib$get_vm(&n, &b));
2613         b->buf = (char *) b + sizeof(CBuf);
2614     } else {
2615        _ckvmssts(iss);
2616     }
2617
2618     p->curr = b;
2619     iss = sys$qio(0,p->chan_in,
2620              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2621              &p->iosb,
2622              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2623     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2624     _ckvmssts(iss);
2625 }
2626
2627
2628 /* writes queued buffers to output, waits for each to complete before
2629    doing the next */
2630
2631 static void
2632 pipe_tochild2_ast(pPipe p)
2633 {
2634     pCBuf b = p->curr2;
2635     int iss = p->iosb2.status;
2636     int n = sizeof(CBuf) + p->bufsize;
2637     int done = (p->info && p->info->done) ||
2638               iss == SS$_CANCEL || iss == SS$_ABORT;
2639 #if defined(PERL_IMPLICIT_CONTEXT)
2640     pTHX = p->thx;
2641 #endif
2642
2643     do {
2644         if (p->type) {         /* type=1 has old buffer, dispose */
2645             if (p->shut_on_empty) {
2646                 _ckvmssts(lib$free_vm(&n, &b));
2647             } else {
2648                 _ckvmssts(lib$insqhi(b, &p->free));
2649             }
2650             p->type = 0;
2651         }
2652
2653         iss = lib$remqti(&p->wait, &b);
2654         if (iss == LIB$_QUEWASEMP) {
2655             if (p->shut_on_empty) {
2656                 if (done) {
2657                     _ckvmssts(sys$dassgn(p->chan_out));
2658                     *p->pipe_done = TRUE;
2659                     _ckvmssts(sys$setef(pipe_ef));
2660                 } else {
2661                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2662                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2663                 }
2664                 return;
2665             }
2666             p->need_wake = TRUE;
2667             return;
2668         }
2669         _ckvmssts(iss);
2670         p->type = 1;
2671     } while (done);
2672
2673
2674     p->curr2 = b;
2675     if (b->eof) {
2676         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2677             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2678     } else {
2679         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2680             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2681     }
2682
2683     return;
2684
2685 }
2686
2687
2688 static pPipe
2689 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2690 {
2691     pPipe p;
2692     char mbx1[64], mbx2[64];
2693     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2694                                       DSC$K_CLASS_S, mbx1},
2695                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2696                                       DSC$K_CLASS_S, mbx2};
2697     unsigned int dviitm = DVI$_DEVBUFSIZ;
2698
2699     int n = sizeof(Pipe);
2700     _ckvmssts(lib$get_vm(&n, &p));
2701     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2702     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2703
2704     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2705     n = p->bufsize * sizeof(char);
2706     _ckvmssts(lib$get_vm(&n, &p->buf));
2707     p->shut_on_empty = FALSE;
2708     p->info   = 0;
2709     p->type   = 0;
2710     p->iosb.status = SS$_NORMAL;
2711 #if defined(PERL_IMPLICIT_CONTEXT)
2712     p->thx = aTHX;
2713 #endif
2714     pipe_infromchild_ast(p);
2715
2716     strcpy(wmbx, mbx1);
2717     strcpy(rmbx, mbx2);
2718     return p;
2719 }
2720
2721 static void
2722 pipe_infromchild_ast(pPipe p)
2723 {
2724     int iss = p->iosb.status;
2725     int eof = (iss == SS$_ENDOFFILE);
2726     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2727     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2728 #if defined(PERL_IMPLICIT_CONTEXT)
2729     pTHX = p->thx;
2730 #endif
2731
2732     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2733         _ckvmssts(sys$dassgn(p->chan_out));
2734         p->chan_out = 0;
2735     }
2736
2737     /* read completed:
2738             input shutdown if EOF from self (done or shut_on_empty)
2739             output shutdown if closing flag set (my_pclose)
2740             send data/eof from child or eof from self
2741             otherwise, re-read (snarf of data from child)
2742     */
2743
2744     if (p->type == 1) {
2745         p->type = 0;
2746         if (myeof && p->chan_in) {                  /* input shutdown */
2747             _ckvmssts(sys$dassgn(p->chan_in));
2748             p->chan_in = 0;
2749         }
2750
2751         if (p->chan_out) {
2752             if (myeof || kideof) {      /* pass EOF to parent */
2753                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2754                               pipe_infromchild_ast, p,
2755                               0, 0, 0, 0, 0, 0));
2756                 return;
2757             } else if (eof) {       /* eat EOF --- fall through to read*/
2758
2759             } else {                /* transmit data */
2760                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2761                               pipe_infromchild_ast,p,
2762                               p->buf, p->iosb.count, 0, 0, 0, 0));
2763                 return;
2764             }
2765         }
2766     }
2767
2768     /*  everything shut? flag as done */
2769
2770     if (!p->chan_in && !p->chan_out) {
2771         *p->pipe_done = TRUE;
2772         _ckvmssts(sys$setef(pipe_ef));
2773         return;
2774     }
2775
2776     /* write completed (or read, if snarfing from child)
2777             if still have input active,
2778                queue read...immediate mode if shut_on_empty so we get EOF if empty
2779             otherwise,
2780                check if Perl reading, generate EOFs as needed
2781     */
2782
2783     if (p->type == 0) {
2784         p->type = 1;
2785         if (p->chan_in) {
2786             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2787                           pipe_infromchild_ast,p,
2788                           p->buf, p->bufsize, 0, 0, 0, 0);
2789             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2790             _ckvmssts(iss);
2791         } else {           /* send EOFs for extra reads */
2792             p->iosb.status = SS$_ENDOFFILE;
2793             p->iosb.dvispec = 0;
2794             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2795                       0, 0, 0,
2796                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2797         }
2798     }
2799 }
2800
2801 static pPipe
2802 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2803 {
2804     pPipe p;
2805     char mbx[64];
2806     unsigned long dviitm = DVI$_DEVBUFSIZ;
2807     struct stat s;
2808     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2809                                       DSC$K_CLASS_S, mbx};
2810     int n = sizeof(Pipe);
2811
2812     /* things like terminals and mbx's don't need this filter */
2813     if (fd && fstat(fd,&s) == 0) {
2814         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2815         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2816                                          DSC$K_CLASS_S, s.st_dev};
2817
2818         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2819         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2820             strcpy(out, s.st_dev);
2821             return 0;
2822         }
2823     }
2824
2825     _ckvmssts(lib$get_vm(&n, &p));
2826     p->fd_out = dup(fd);
2827     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2828     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2829     n = (p->bufsize+1) * sizeof(char);
2830     _ckvmssts(lib$get_vm(&n, &p->buf));
2831     p->shut_on_empty = FALSE;
2832     p->retry = 0;
2833     p->info  = 0;
2834     strcpy(out, mbx);
2835
2836     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2837                   pipe_mbxtofd_ast, p,
2838                   p->buf, p->bufsize, 0, 0, 0, 0));
2839
2840     return p;
2841 }
2842
2843 static void
2844 pipe_mbxtofd_ast(pPipe p)
2845 {
2846     int iss = p->iosb.status;
2847     int done = p->info->done;
2848     int iss2;
2849     int eof = (iss == SS$_ENDOFFILE);
2850     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2851     int err = !(iss&1) && !eof;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2853     pTHX = p->thx;
2854 #endif
2855
2856     if (done && myeof) {               /* end piping */
2857         close(p->fd_out);
2858         sys$dassgn(p->chan_in);
2859         *p->pipe_done = TRUE;
2860         _ckvmssts(sys$setef(pipe_ef));
2861         return;
2862     }
2863
2864     if (!err && !eof) {             /* good data to send to file */
2865         p->buf[p->iosb.count] = '\n';
2866         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2867         if (iss2 < 0) {
2868             p->retry++;
2869             if (p->retry < MAX_RETRY) {
2870                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2871                 return;
2872             }
2873         }
2874         p->retry = 0;
2875     } else if (err) {
2876         _ckvmssts(iss);
2877     }
2878
2879
2880     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2881           pipe_mbxtofd_ast, p,
2882           p->buf, p->bufsize, 0, 0, 0, 0);
2883     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2884     _ckvmssts(iss);
2885 }
2886
2887
2888 typedef struct _pipeloc     PLOC;
2889 typedef struct _pipeloc*   pPLOC;
2890
2891 struct _pipeloc {
2892     pPLOC   next;
2893     char    dir[NAM$C_MAXRSS+1];
2894 };
2895 static pPLOC  head_PLOC = 0;
2896
2897 void
2898 free_pipelocs(pTHX_ void *head)
2899 {
2900     pPLOC p, pnext;
2901     pPLOC *pHead = (pPLOC *)head;
2902
2903     p = *pHead;
2904     while (p) {
2905         pnext = p->next;
2906         PerlMem_free(p);
2907         p = pnext;
2908     }
2909     *pHead = 0;
2910 }
2911
2912 static void
2913 store_pipelocs(pTHX)
2914 {
2915     int    i;
2916     pPLOC  p;
2917     AV    *av = 0;
2918     SV    *dirsv;
2919     GV    *gv;
2920     char  *dir, *x;
2921     char  *unixdir;
2922     char  temp[NAM$C_MAXRSS+1];
2923     STRLEN n_a;
2924
2925     if (head_PLOC)
2926         free_pipelocs(aTHX_ &head_PLOC);
2927
2928 /*  the . directory from @INC comes last */
2929
2930     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2931     p->next = head_PLOC;
2932     head_PLOC = p;
2933     strcpy(p->dir,"./");
2934
2935 /*  get the directory from $^X */
2936
2937 #ifdef PERL_IMPLICIT_CONTEXT
2938     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2939 #else
2940     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2941 #endif
2942         strcpy(temp, PL_origargv[0]);
2943         x = strrchr(temp,']');
2944         if (x == NULL) {
2945         x = strrchr(temp,'>');
2946           if (x == NULL) {
2947             /* It could be a UNIX path */
2948             x = strrchr(temp,'/');
2949           }
2950         }
2951         if (x)
2952           x[1] = '\0';
2953         else {
2954           /* Got a bare name, so use default directory */
2955           temp[0] = '.';
2956           temp[1] = '\0';
2957         }
2958
2959         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2960             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2961             p->next = head_PLOC;
2962             head_PLOC = p;
2963             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2964             p->dir[NAM$C_MAXRSS] = '\0';
2965         }
2966     }
2967
2968 /*  reverse order of @INC entries, skip "." since entered above */
2969
2970 #ifdef PERL_IMPLICIT_CONTEXT
2971     if (aTHX)
2972 #endif
2973     if (PL_incgv) av = GvAVn(PL_incgv);
2974
2975     for (i = 0; av && i <= AvFILL(av); i++) {
2976         dirsv = *av_fetch(av,i,TRUE);
2977
2978         if (SvROK(dirsv)) continue;
2979         dir = SvPVx(dirsv,n_a);
2980         if (strcmp(dir,".") == 0) continue;
2981         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2982             continue;
2983
2984         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2985         p->next = head_PLOC;
2986         head_PLOC = p;
2987         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2988         p->dir[NAM$C_MAXRSS] = '\0';
2989     }
2990
2991 /* most likely spot (ARCHLIB) put first in the list */
2992
2993 #ifdef ARCHLIB_EXP
2994     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2995         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2996         p->next = head_PLOC;
2997         head_PLOC = p;
2998         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2999         p->dir[NAM$C_MAXRSS] = '\0';
3000     }
3001 #endif
3002 }
3003
3004
3005 static char *
3006 find_vmspipe(pTHX)
3007 {
3008     static int   vmspipe_file_status = 0;
3009     static char  vmspipe_file[NAM$C_MAXRSS+1];
3010
3011     /* already found? Check and use ... need read+execute permission */
3012
3013     if (vmspipe_file_status == 1) {
3014         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3015          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3016             return vmspipe_file;
3017         }
3018         vmspipe_file_status = 0;
3019     }
3020
3021     /* scan through stored @INC, $^X */
3022
3023     if (vmspipe_file_status == 0) {
3024         char file[NAM$C_MAXRSS+1];
3025         pPLOC  p = head_PLOC;
3026
3027         while (p) {
3028             strcpy(file, p->dir);
3029             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3030             file[NAM$C_MAXRSS] = '\0';
3031             p = p->next;
3032
3033             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3034
3035             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3036              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3037                 vmspipe_file_status = 1;
3038                 return vmspipe_file;
3039             }
3040         }
3041         vmspipe_file_status = -1;   /* failed, use tempfiles */
3042     }
3043
3044     return 0;
3045 }
3046
3047 static FILE *
3048 vmspipe_tempfile(pTHX)
3049 {
3050     char file[NAM$C_MAXRSS+1];
3051     FILE *fp;
3052     static int index = 0;
3053     Stat_t s0, s1;
3054     int cmp_result;
3055
3056     /* create a tempfile */
3057
3058     /* we can't go from   W, shr=get to  R, shr=get without
3059        an intermediate vulnerable state, so don't bother trying...
3060
3061        and lib$spawn doesn't shr=put, so have to close the write
3062
3063        So... match up the creation date/time and the FID to
3064        make sure we're dealing with the same file
3065
3066     */
3067
3068     index++;
3069     if (!decc_filename_unix_only) {
3070       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3071       fp = fopen(file,"w");
3072       if (!fp) {
3073         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3074         fp = fopen(file,"w");
3075         if (!fp) {
3076             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3077             fp = fopen(file,"w");
3078         }
3079       }
3080      }
3081      else {
3082       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3083       fp = fopen(file,"w");
3084       if (!fp) {
3085         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3086         fp = fopen(file,"w");
3087         if (!fp) {
3088           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3089           fp = fopen(file,"w");
3090         }
3091       }
3092     }
3093     if (!fp) return 0;  /* we're hosed */
3094
3095     fprintf(fp,"$! 'f$verify(0)'\n");
3096     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3097     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3098     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3099     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3100     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3101     fprintf(fp,"$ perl_del    = \"delete\"\n");
3102     fprintf(fp,"$ pif         = \"if\"\n");
3103     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3104     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3105     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3106     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3107     fprintf(fp,"$!  --- build command line to get max possible length\n");
3108     fprintf(fp,"$c=perl_popen_cmd0\n");
3109     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3110     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3111     fprintf(fp,"$x=perl_popen_cmd3\n");
3112     fprintf(fp,"$c=c+x\n");
3113     fprintf(fp,"$ perl_on\n");
3114     fprintf(fp,"$ 'c'\n");
3115     fprintf(fp,"$ perl_status = $STATUS\n");
3116     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3117     fprintf(fp,"$ perl_exit 'perl_status'\n");
3118     fsync(fileno(fp));
3119
3120     fgetname(fp, file, 1);
3121     fstat(fileno(fp), (struct stat *)&s0);
3122     fclose(fp);
3123
3124     if (decc_filename_unix_only)
3125         do_tounixspec(file, file, 0);
3126     fp = fopen(file,"r","shr=get");
3127     if (!fp) return 0;
3128     fstat(fileno(fp), (struct stat *)&s1);
3129
3130     #if defined(_USE_STD_STAT)
3131       cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3132     #else
3133       cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3134     #endif
3135     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3136         fclose(fp);
3137         return 0;
3138     }
3139
3140     return fp;
3141 }
3142
3143
3144
3145 static PerlIO *
3146 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3147 {
3148     static int handler_set_up = FALSE;
3149     unsigned long int sts, flags = CLI$M_NOWAIT;
3150     /* The use of a GLOBAL table (as was done previously) rendered
3151      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3152      * environment.  Hence we've switched to LOCAL symbol table.
3153      */
3154     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3155     int j, wait = 0, n;
3156     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3157     char in[512], out[512], err[512], mbx[512];
3158     FILE *tpipe = 0;
3159     char tfilebuf[NAM$C_MAXRSS+1];
3160     pInfo info = NULL;
3161     char cmd_sym_name[20];
3162     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3163                                       DSC$K_CLASS_S, symbol};
3164     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3165                                       DSC$K_CLASS_S, 0};
3166     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3167                                       DSC$K_CLASS_S, cmd_sym_name};
3168     struct dsc$descriptor_s *vmscmd;
3169     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3170     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3171     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3172
3173     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3174
3175     /* once-per-program initialization...
3176        note that the SETAST calls and the dual test of pipe_ef
3177        makes sure that only the FIRST thread through here does
3178        the initialization...all other threads wait until it's
3179        done.
3180
3181        Yeah, uglier than a pthread call, it's got all the stuff inline
3182        rather than in a separate routine.
3183     */
3184
3185     if (!pipe_ef) {
3186         _ckvmssts(sys$setast(0));
3187         if (!pipe_ef) {
3188             unsigned long int pidcode = JPI$_PID;
3189             $DESCRIPTOR(d_delay, RETRY_DELAY);
3190             _ckvmssts(lib$get_ef(&pipe_ef));
3191             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3192             _ckvmssts(sys$bintim(&d_delay, delaytime));
3193         }
3194         if (!handler_set_up) {
3195           _ckvmssts(sys$dclexh(&pipe_exitblock));
3196           handler_set_up = TRUE;
3197         }
3198         _ckvmssts(sys$setast(1));
3199     }
3200
3201     /* see if we can find a VMSPIPE.COM */
3202
3203     tfilebuf[0] = '@';
3204     vmspipe = find_vmspipe(aTHX);
3205     if (vmspipe) {
3206         strcpy(tfilebuf+1,vmspipe);
3207     } else {        /* uh, oh...we're in tempfile hell */
3208         tpipe = vmspipe_tempfile(aTHX);
3209         if (!tpipe) {       /* a fish popular in Boston */
3210             if (ckWARN(WARN_PIPE)) {
3211                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3212             }
3213         return Nullfp;
3214         }
3215         fgetname(tpipe,tfilebuf+1,1);
3216     }
3217     vmspipedsc.dsc$a_pointer = tfilebuf;
3218     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3219
3220     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3221     if (!(sts & 1)) {
3222       switch (sts) {
3223         case RMS$_FNF:  case RMS$_DNF:
3224           set_errno(ENOENT); break;
3225         case RMS$_DIR:
3226           set_errno(ENOTDIR); break;
3227         case RMS$_DEV:
3228           set_errno(ENODEV); break;
3229         case RMS$_PRV:
3230           set_errno(EACCES); break;
3231         case RMS$_SYN:
3232           set_errno(EINVAL); break;
3233         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3234           set_errno(E2BIG); break;
3235         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3236           _ckvmssts(sts); /* fall through */
3237         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3238           set_errno(EVMSERR);
3239       }
3240       set_vaxc_errno(sts);
3241       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3242         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3243       }
3244       *psts = sts;
3245       return Nullfp;
3246     }
3247     n = sizeof(Info);
3248     _ckvmssts(lib$get_vm(&n, &info));
3249
3250     strcpy(mode,in_mode);
3251     info->mode = *mode;
3252     info->done = FALSE;
3253     info->completion = 0;
3254     info->closing    = FALSE;
3255     info->in         = 0;
3256     info->out        = 0;
3257     info->err        = 0;
3258     info->fp         = Nullfp;
3259     info->useFILE    = 0;
3260     info->waiting    = 0;
3261     info->in_done    = TRUE;
3262     info->out_done   = TRUE;
3263     info->err_done   = TRUE;
3264     in[0] = out[0] = err[0] = '\0';
3265
3266     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3267         info->useFILE = 1;
3268         strcpy(p,p+1);
3269     }
3270     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3271         wait = 1;
3272         strcpy(p,p+1);
3273     }
3274
3275     if (*mode == 'r') {             /* piping from subroutine */
3276
3277         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3278         if (info->out) {
3279             info->out->pipe_done = &info->out_done;
3280             info->out_done = FALSE;
3281             info->out->info = info;
3282         }
3283         if (!info->useFILE) {
3284         info->fp  = PerlIO_open(mbx, mode);
3285         } else {
3286             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3287             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3288         }
3289
3290         if (!info->fp && info->out) {
3291             sys$cancel(info->out->chan_out);
3292
3293             while (!info->out_done) {
3294                 int done;
3295                 _ckvmssts(sys$setast(0));
3296                 done = info->out_done;
3297                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3298                 _ckvmssts(sys$setast(1));
3299                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3300             }
3301
3302             if (info->out->buf) {
3303                 n = info->out->bufsize * sizeof(char);
3304                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3305             }
3306             n = sizeof(Pipe);
3307             _ckvmssts(lib$free_vm(&n, &info->out));
3308             n = sizeof(Info);
3309             _ckvmssts(lib$free_vm(&n, &info));
3310             *psts = RMS$_FNF;
3311             return Nullfp;
3312         }
3313
3314         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3315         if (info->err) {
3316             info->err->pipe_done = &info->err_done;
3317             info->err_done = FALSE;
3318             info->err->info = info;
3319         }
3320
3321     } else if (*mode == 'w') {      /* piping to subroutine */
3322
3323         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3324         if (info->out) {
3325             info->out->pipe_done = &info->out_done;
3326             info->out_done = FALSE;
3327             info->out->info = info;
3328         }
3329
3330         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3331         if (info->err) {
3332             info->err->pipe_done = &info->err_done;
3333             info->err_done = FALSE;
3334             info->err->info = info;
3335         }
3336
3337         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3338         if (!info->useFILE) {
3339             info->fp  = PerlIO_open(mbx, mode);
3340         } else {
3341             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3342             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3343         }
3344
3345         if (info->in) {
3346             info->in->pipe_done = &info->in_done;
3347             info->in_done = FALSE;
3348             info->in->info = info;
3349         }
3350
3351         /* error cleanup */
3352         if (!info->fp && info->in) {
3353             info->done = TRUE;
3354             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3355                               0, 0, 0, 0, 0, 0, 0, 0));
3356
3357             while (!info->in_done) {
3358                 int done;
3359                 _ckvmssts(sys$setast(0));
3360                 done = info->in_done;
3361                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3362                 _ckvmssts(sys$setast(1));
3363                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3364             }
3365
3366             if (info->in->buf) {
3367                 n = info->in->bufsize * sizeof(char);
3368                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3369             }
3370             n = sizeof(Pipe);
3371             _ckvmssts(lib$free_vm(&n, &info->in));
3372             n = sizeof(Info);
3373             _ckvmssts(lib$free_vm(&n, &info));
3374             *psts = RMS$_FNF;
3375             return Nullfp;
3376         }
3377
3378
3379     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3380         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3381         if (info->out) {
3382             info->out->pipe_done = &info->out_done;
3383             info->out_done = FALSE;
3384             info->out->info = info;
3385         }
3386
3387         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3388         if (info->err) {
3389             info->err->pipe_done = &info->err_done;
3390             info->err_done = FALSE;
3391             info->err->info = info;
3392         }
3393     }
3394
3395     symbol[MAX_DCL_SYMBOL] = '\0';
3396
3397     strncpy(symbol, in, MAX_DCL_SYMBOL);
3398     d_symbol.dsc$w_length = strlen(symbol);
3399     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3400
3401     strncpy(symbol, err, MAX_DCL_SYMBOL);
3402     d_symbol.dsc$w_length = strlen(symbol);
3403     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3404
3405     strncpy(symbol, out, MAX_DCL_SYMBOL);
3406     d_symbol.dsc$w_length = strlen(symbol);
3407     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3408
3409     p = vmscmd->dsc$a_pointer;
3410     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3411     if (*p == '$') p++;                         /* remove leading $ */
3412     while (*p == ' ' || *p == '\t') p++;
3413
3414     for (j = 0; j < 4; j++) {
3415         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3416         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3417
3418     strncpy(symbol, p, MAX_DCL_SYMBOL);
3419     d_symbol.dsc$w_length = strlen(symbol);
3420     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3421
3422         if (strlen(p) > MAX_DCL_SYMBOL) {
3423             p += MAX_DCL_SYMBOL;
3424         } else {
3425             p += strlen(p);
3426         }
3427     }
3428     _ckvmssts(sys$setast(0));
3429     info->next=open_pipes;  /* prepend to list */
3430     open_pipes=info;
3431     _ckvmssts(sys$setast(1));
3432     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3433      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3434      * have SYS$COMMAND if we need it.
3435      */
3436     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3437                       0, &info->pid, &info->completion,
3438                       0, popen_completion_ast,info,0,0,0));
3439
3440     /* if we were using a tempfile, close it now */
3441
3442     if (tpipe) fclose(tpipe);
3443
3444     /* once the subprocess is spawned, it has copied the symbols and
3445        we can get rid of ours */
3446
3447     for (j = 0; j < 4; j++) {
3448         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3449         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3450     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3451     }
3452     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3453     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3454     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3455     vms_execfree(vmscmd);
3456
3457 #ifdef PERL_IMPLICIT_CONTEXT
3458     if (aTHX)
3459 #endif
3460     PL_forkprocess = info->pid;
3461
3462     if (wait) {
3463          int done = 0;
3464          while (!done) {
3465              _ckvmssts(sys$setast(0));
3466              done = info->done;
3467              if (!done) _ckvmssts(sys$clref(pipe_ef));
3468              _ckvmssts(sys$setast(1));
3469              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3470          }
3471         *psts = info->completion;
3472 /* Caller thinks it is open and tries to close it. */
3473 /* This causes some problems, as it changes the error status */
3474 /*        my_pclose(info->fp); */
3475     } else {
3476         *psts = SS$_NORMAL;
3477     }
3478     return info->fp;
3479 }  /* end of safe_popen */
3480
3481
3482 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3483 PerlIO *
3484 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3485 {
3486     int sts;
3487     TAINT_ENV();
3488     TAINT_PROPER("popen");
3489     PERL_FLUSHALL_FOR_CHILD;
3490     return safe_popen(aTHX_ cmd,mode,&sts);
3491 }
3492
3493 /*}}}*/
3494
3495 /*{{{  I32 my_pclose(PerlIO *fp)*/
3496 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3497 {
3498     pInfo info, last = NULL;
3499     unsigned long int retsts;
3500     int done, iss, n;
3501
3502     for (info = open_pipes; info != NULL; last = info, info = info->next)
3503         if (info->fp == fp) break;
3504
3505     if (info == NULL) {  /* no such pipe open */
3506       set_errno(ECHILD); /* quoth POSIX */
3507       set_vaxc_errno(SS$_NONEXPR);
3508       return -1;
3509     }
3510
3511     /* If we were writing to a subprocess, insure that someone reading from
3512      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3513      * produce an EOF record in the mailbox.
3514      *
3515      *  well, at least sometimes it *does*, so we have to watch out for
3516      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3517      */
3518      if (info->fp) {
3519         if (!info->useFILE)
3520             PerlIO_flush(info->fp);   /* first, flush data */
3521         else
3522             fflush((FILE *)info->fp);
3523     }
3524
3525     _ckvmssts(sys$setast(0));
3526      info->closing = TRUE;
3527      done = info->done && info->in_done && info->out_done && info->err_done;
3528      /* hanging on write to Perl's input? cancel it */
3529      if (info->mode == 'r' && info->out && !info->out_done) {
3530         if (info->out->chan_out) {
3531             _ckvmssts(sys$cancel(info->out->chan_out));
3532             if (!info->out->chan_in) {   /* EOF generation, need AST */
3533                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3534             }
3535         }
3536      }
3537      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3538          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3539                            0, 0, 0, 0, 0, 0));
3540     _ckvmssts(sys$setast(1));
3541     if (info->fp) {
3542      if (!info->useFILE)
3543         PerlIO_close(info->fp);
3544      else
3545         fclose((FILE *)info->fp);
3546     }
3547      /*
3548         we have to wait until subprocess completes, but ALSO wait until all
3549         the i/o completes...otherwise we'll be freeing the "info" structure
3550         that the i/o ASTs could still be using...
3551      */
3552
3553      while (!done) {
3554          _ckvmssts(sys$setast(0));
3555          done = info->done && info->in_done && info->out_done && info->err_done;
3556          if (!done) _ckvmssts(sys$clref(pipe_ef));
3557          _ckvmssts(sys$setast(1));
3558          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3559      }
3560      retsts = info->completion;
3561
3562     /* remove from list of open pipes */
3563     _ckvmssts(sys$setast(0));
3564     if (last) last->next = info->next;
3565     else open_pipes = info->next;
3566     _ckvmssts(sys$setast(1));
3567
3568     /* free buffers and structures */
3569
3570     if (info->in) {
3571         if (info->in->buf) {
3572             n = info->in->bufsize * sizeof(char);
3573             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3574         }
3575         n = sizeof(Pipe);
3576         _ckvmssts(lib$free_vm(&n, &info->in));
3577     }
3578     if (info->out) {
3579         if (info->out->buf) {
3580             n = info->out->bufsize * sizeof(char);
3581             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3582         }
3583         n = sizeof(Pipe);
3584         _ckvmssts(lib$free_vm(&n, &info->out));
3585     }
3586     if (info->err) {
3587         if (info->err->buf) {
3588             n = info->err->bufsize * sizeof(char);
3589             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3590         }
3591         n = sizeof(Pipe);
3592         _ckvmssts(lib$free_vm(&n, &info->err));
3593     }
3594     n = sizeof(Info);
3595     _ckvmssts(lib$free_vm(&n, &info));
3596
3597     return retsts;
3598
3599 }  /* end of my_pclose() */
3600
3601 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3602   /* Roll our own prototype because we want this regardless of whether
3603    * _VMS_WAIT is defined.
3604    */
3605   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3606 #endif
3607 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3608    created with popen(); otherwise partially emulate waitpid() unless
3609    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3610    Also check processes not considered by the CRTL waitpid().
3611  */
3612 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3613 Pid_t
3614 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3615 {
3616     pInfo info;
3617     int done;
3618     int sts;
3619     int j;
3620
3621     if (statusp) *statusp = 0;
3622
3623     for (info = open_pipes; info != NULL; info = info->next)
3624         if (info->pid == pid) break;
3625
3626     if (info != NULL) {  /* we know about this child */
3627       while (!info->done) {
3628           _ckvmssts(sys$setast(0));
3629           done = info->done;
3630           if (!done) _ckvmssts(sys$clref(pipe_ef));
3631           _ckvmssts(sys$setast(1));
3632           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3633       }
3634
3635       if (statusp) *statusp = info->completion;
3636       return pid;
3637     }
3638
3639     /* child that already terminated? */
3640
3641     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3642         if (closed_list[j].pid == pid) {
3643             if (statusp) *statusp = closed_list[j].completion;
3644             return pid;
3645         }
3646     }
3647
3648     /* fall through if this child is not one of our own pipe children */
3649
3650 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3651
3652       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3653        * in 7.2 did we get a version that fills in the VMS completion
3654        * status as Perl has always tried to do.
3655        */
3656
3657       sts = __vms_waitpid( pid, statusp, flags );
3658
3659       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3660          return sts;
3661
3662       /* If the real waitpid tells us the child does not exist, we
3663        * fall through here to implement waiting for a child that
3664        * was created by some means other than exec() (say, spawned
3665        * from DCL) or to wait for a process that is not a subprocess
3666        * of the current process.
3667        */
3668
3669 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3670
3671     {
3672       $DESCRIPTOR(intdsc,"0 00:00:01");
3673       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3674       unsigned long int pidcode = JPI$_PID, mypid;
3675       unsigned long int interval[2];
3676       unsigned int jpi_iosb[2];
3677       struct itmlst_3 jpilist[2] = {
3678           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3679           {                      0,         0,                 0, 0}
3680       };
3681
3682       if (pid <= 0) {
3683         /* Sorry folks, we don't presently implement rooting around for
3684            the first child we can find, and we definitely don't want to
3685            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3686          */
3687         set_errno(ENOTSUP);
3688         return -1;
3689       }
3690
3691       /* Get the owner of the child so I can warn if it's not mine. If the
3692        * process doesn't exist or I don't have the privs to look at it,
3693        * I can go home early.
3694        */
3695       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3696       if (sts & 1) sts = jpi_iosb[0];
3697       if (!(sts & 1)) {
3698         switch (sts) {
3699             case SS$_NONEXPR:
3700                 set_errno(ECHILD);
3701                 break;
3702             case SS$_NOPRIV:
3703                 set_errno(EACCES);
3704                 break;
3705             default:
3706                 _ckvmssts(sts);
3707         }
3708         set_vaxc_errno(sts);
3709         return -1;
3710       }
3711
3712       if (ckWARN(WARN_EXEC)) {
3713         /* remind folks they are asking for non-standard waitpid behavior */
3714         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3715         if (ownerpid != mypid)
3716           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3717                       "waitpid: process %x is not a child of process %x",
3718                       pid,mypid);
3719       }
3720
3721       /* simply check on it once a second until it's not there anymore. */
3722
3723       _ckvmssts(sys$bintim(&intdsc,interval));
3724       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3725             _ckvmssts(sys$schdwk(0,0,interval,0));
3726             _ckvmssts(sys$hiber());
3727       }
3728       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3729
3730       _ckvmssts(sts);
3731       return pid;
3732     }
3733 }  /* end of waitpid() */
3734 /*}}}*/
3735 /*}}}*/
3736 /*}}}*/
3737
3738 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3739 char *
3740 my_gconvert(double val, int ndig, int trail, char *buf)
3741 {
3742   static char __gcvtbuf[DBL_DIG+1];
3743   char *loc;
3744
3745   loc = buf ? buf : __gcvtbuf;
3746
3747 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3748   if (val < 1) {
3749     sprintf(loc,"%.*g",ndig,val);
3750     return loc;
3751   }
3752 #endif
3753
3754   if (val) {
3755     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3756     return gcvt(val,ndig,loc);
3757   }
3758   else {
3759     loc[0] = '0'; loc[1] = '\0';
3760     return loc;
3761   }
3762
3763 }
3764 /*}}}*/
3765
3766 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3767 static int rms_free_search_context(struct FAB * fab)
3768 {
3769 struct NAM * nam;
3770
3771     nam = fab->fab$l_nam;
3772     nam->nam$b_nop |= NAM$M_SYNCHK;
3773     nam->nam$l_rlf = NULL;
3774     fab->fab$b_dns = 0;
3775     return sys$parse(fab, NULL, NULL);
3776 }
3777
3778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3779 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3780 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3781 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3782 #define rms_nam_esll(nam) nam.nam$b_esl
3783 #define rms_nam_esl(nam) nam.nam$b_esl
3784 #define rms_nam_name(nam) nam.nam$l_name
3785 #define rms_nam_namel(nam) nam.nam$l_name
3786 #define rms_nam_type(nam) nam.nam$l_type
3787 #define rms_nam_typel(nam) nam.nam$l_type
3788 #define rms_nam_ver(nam) nam.nam$l_ver
3789 #define rms_nam_verl(nam) nam.nam$l_ver
3790 #define rms_nam_rsll(nam) nam.nam$b_rsl
3791 #define rms_nam_rsl(nam) nam.nam$b_rsl
3792 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3793 #define rms_set_fna(fab, nam, name, size) \
3794         fab.fab$b_fns = size; fab.fab$l_fna = name;
3795 #define rms_get_fna(fab, nam) fab.fab$l_fna
3796 #define rms_set_dna(fab, nam, name, size) \
3797         fab.fab$b_dns = size; fab.fab$l_dna = name;
3798 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3799 #define rms_set_esa(fab, nam, name, size) \
3800         nam.nam$b_ess = size; nam.nam$l_esa = name;
3801 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3802         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3803 #define rms_set_rsa(nam, name, size) \
3804         nam.nam$l_rsa = name; nam.nam$b_rss = size;
3805 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3806         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3807
3808 #else
3809 static int rms_free_search_context(struct FAB * fab)
3810 {
3811 struct NAML * nam;
3812
3813     nam = fab->fab$l_naml;
3814     nam->naml$b_nop |= NAM$M_SYNCHK;
3815     nam->naml$l_rlf = NULL;
3816     nam->naml$l_long_defname_size = 0;
3817     fab->fab$b_dns = 0;
3818     return sys$parse(fab, NULL, NULL);
3819 }
3820
3821 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3822 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3823 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3824 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3825 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3826 #define rms_nam_esl(nam) nam.naml$b_esl
3827 #define rms_nam_name(nam) nam.naml$l_name
3828 #define rms_nam_namel(nam) nam.naml$l_long_name
3829 #define rms_nam_type(nam) nam.naml$l_type
3830 #define rms_nam_typel(nam) nam.naml$l_long_type
3831 #define rms_nam_ver(nam) nam.naml$l_ver
3832 #define rms_nam_verl(nam) nam.naml$l_long_ver
3833 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3834 #define rms_nam_rsl(nam) nam.naml$b_rsl
3835 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3836 #define rms_set_fna(fab, nam, name, size) \
3837         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3838         nam.naml$l_long_filename_size = size; \
3839         nam.naml$l_long_filename = name
3840 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3841 #define rms_set_dna(fab, nam, name, size) \
3842         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3843         nam.naml$l_long_defname_size = size; \
3844         nam.naml$l_long_defname = name
3845 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3846 #define rms_set_esa(fab, nam, name, size) \
3847         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3848         nam.naml$l_long_expand_alloc = size; \
3849         nam.naml$l_long_expand = name
3850 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3851         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3852         nam.naml$l_long_expand = l_name; \
3853         nam.naml$l_long_expand_alloc = l_size;
3854 #define rms_set_rsa(nam, name, size) \
3855         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3856         nam.naml$l_long_result = name; \
3857         nam.naml$l_long_result_alloc = size;
3858 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3859         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3860         nam.naml$l_long_result = l_name; \
3861         nam.naml$l_long_result_alloc = l_size;
3862
3863 #endif
3864
3865
3866 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3867 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3868  * to expand file specification.  Allows for a single default file
3869  * specification and a simple mask of options.  If outbuf is non-NULL,
3870  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3871  * the resultant file specification is placed.  If outbuf is NULL, the
3872  * resultant file specification is placed into a static buffer.
3873  * The third argument, if non-NULL, is taken to be a default file
3874  * specification string.  The fourth argument is unused at present.
3875  * rmesexpand() returns the address of the resultant string if
3876  * successful, and NULL on error.
3877  *
3878  * New functionality for previously unused opts value:
3879  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3880  */
3881 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3882
3883 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3884 /* ODS-2 only version */
3885 static char *
3886 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3887 {
3888   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3889   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3890   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3891   struct FAB myfab = cc$rms_fab;
3892   struct NAM mynam = cc$rms_nam;
3893   STRLEN speclen;
3894   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3895   int sts;
3896
3897   if (!filespec || !*filespec) {
3898     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3899     return NULL;
3900   }
3901   if (!outbuf) {
3902     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3903     else    outbuf = __rmsexpand_retbuf;
3904   }
3905   isunix = is_unix_filespec(filespec);
3906   if (isunix) {
3907     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3908         if (out)
3909            Safefree(out);
3910         return NULL;
3911     }
3912     filespec = vmsfspec;
3913   }
3914
3915   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3916   myfab.fab$b_fns = strlen(filespec);
3917   myfab.fab$l_nam = &mynam;
3918
3919   if (defspec && *defspec) {
3920     if (strchr(defspec,'/') != NULL) {
3921       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3922         if (out)
3923            Safefree(out);
3924         return NULL;
3925       }
3926       defspec = tmpfspec;
3927     }
3928     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3929     myfab.fab$b_dns = strlen(defspec);
3930   }
3931
3932   mynam.nam$l_esa = esa;
3933   mynam.nam$b_ess = sizeof esa;
3934   mynam.nam$l_rsa = outbuf;
3935   mynam.nam$b_rss = NAM$C_MAXRSS;
3936
3937 #ifdef NAM$M_NO_SHORT_UPCASE
3938   if (decc_efs_case_preserve)
3939     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3940 #endif
3941
3942   retsts = sys$parse(&myfab,0,0);
3943   if (!(retsts & 1)) {
3944     mynam.nam$b_nop |= NAM$M_SYNCHK;
3945     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3946       retsts = sys$parse(&myfab,0,0);
3947       if (retsts & 1) goto expanded;
3948     }
3949     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3950     sts = sys$parse(&myfab,0,0);  /* Free search context */
3951     if (out) Safefree(out);
3952     set_vaxc_errno(retsts);
3953     if      (retsts == RMS$_PRV) set_errno(EACCES);
3954     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3955     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3956     else                         set_errno(EVMSERR);
3957     return NULL;
3958   }
3959   retsts = sys$search(&myfab,0,0);
3960   if (!(retsts & 1) && retsts != RMS$_FNF) {
3961     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3962     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3963     if (out) Safefree(out);
3964     set_vaxc_errno(retsts);
3965     if      (retsts == RMS$_PRV) set_errno(EACCES);
3966     else                         set_errno(EVMSERR);
3967     return NULL;
3968   }
3969
3970   /* If the input filespec contained any lowercase characters,
3971    * downcase the result for compatibility with Unix-minded code. */
3972   expanded:
3973   if (!decc_efs_case_preserve) {
3974     for (out = myfab.fab$l_fna; *out; out++)
3975       if (islower(*out)) { haslower = 1; break; }
3976   }
3977   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3978   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3979   /* Trim off null fields added by $PARSE
3980    * If type > 1 char, must have been specified in original or default spec
3981    * (not true for version; $SEARCH may have added version of existing file).
3982    */
3983   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3984   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3985              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3986   if (trimver || trimtype) {
3987     if (defspec && *defspec) {
3988       char defesa[NAM$C_MAXRSS];
3989       struct FAB deffab = cc$rms_fab;
3990       struct NAM defnam = cc$rms_nam;
3991
3992       deffab.fab$l_nam = &defnam;
3993       /* cast below ok for read only pointer */
3994       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3995       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3996       defnam.nam$b_nop = NAM$M_SYNCHK;
3997 #ifdef NAM$M_NO_SHORT_UPCASE
3998       if (decc_efs_case_preserve)
3999         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4000 #endif
4001       if (sys$parse(&deffab,0,0) & 1) {
4002         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4003         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4004       }
4005     }
4006     if (trimver) {
4007       if (*mynam.nam$l_ver != '\"')
4008         speclen = mynam.nam$l_ver - out;
4009     }
4010     if (trimtype) {
4011       /* If we didn't already trim version, copy down */
4012       if (speclen > mynam.nam$l_ver - out)
4013         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4014                speclen - (mynam.nam$l_ver - out));
4015       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4016     }
4017   }
4018   /* If we just had a directory spec on input, $PARSE "helpfully"
4019    * adds an empty name and type for us */
4020   if (mynam.nam$l_name == mynam.nam$l_type &&
4021       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4022       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4023     speclen = mynam.nam$l_name - out;
4024
4025   /* Posix format specifications must have matching quotes */
4026   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4027     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4028       out[speclen] = '\"';
4029       speclen++;
4030     }
4031   }
4032
4033   out[speclen] = '\0';
4034   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4035
4036   /* Have we been working with an expanded, but not resultant, spec? */
4037   /* Also, convert back to Unix syntax if necessary. */
4038   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4039     isunix = 0;
4040
4041   if (!mynam.nam$b_rsl) {
4042     if (isunix) {
4043       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4044     }
4045     else strcpy(outbuf,esa);
4046   }
4047   else if (isunix) {
4048     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4049     strcpy(outbuf,tmpfspec);
4050   }
4051   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4052   mynam.nam$l_rsa = NULL;
4053   mynam.nam$b_rss = 0;
4054   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4055   return outbuf;
4056 }
4057 #else
4058 /* ODS-5 supporting routine */
4059 static char *
4060 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4061 {
4062   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4063   char * vmsfspec, *tmpfspec;
4064   char * esa, *cp, *out = NULL;
4065   char * esal;
4066   char * outbufl;
4067   struct FAB myfab = cc$rms_fab;
4068   rms_setup_nam(mynam);
4069   STRLEN speclen;
4070   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4071   int sts;
4072
4073   if (!filespec || !*filespec) {
4074     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4075     return NULL;
4076   }
4077   if (!outbuf) {
4078     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4079     else    outbuf = __rmsexpand_retbuf;
4080   }
4081
4082   vmsfspec = NULL;
4083   tmpfspec = NULL;
4084   outbufl = NULL;
4085   isunix = is_unix_filespec(filespec);
4086   if (isunix) {
4087     Newx(vmsfspec, VMS_MAXRSS, char);
4088     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4089         Safefree(vmsfspec);
4090         if (out)
4091            Safefree(out);
4092         return NULL;
4093     }
4094     filespec = vmsfspec;
4095
4096      /* Unless we are forcing to VMS format, a UNIX input means
4097       * UNIX output, and that requires long names to be used
4098       */
4099     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4100         opts |= PERL_RMSEXPAND_M_LONG;
4101     else {
4102         isunix = 0;
4103     }
4104   }
4105
4106   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4107   rms_bind_fab_nam(myfab, mynam);
4108
4109   if (defspec && *defspec) {
4110     int t_isunix;
4111     t_isunix = is_unix_filespec(defspec);
4112     if (t_isunix) {
4113       Newx(tmpfspec, VMS_MAXRSS, char);
4114       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4115         Safefree(tmpfspec);
4116         if (vmsfspec != NULL)
4117             Safefree(vmsfspec);
4118         if (out)
4119            Safefree(out);
4120         return NULL;
4121       }
4122       defspec = tmpfspec;
4123     }
4124     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4125   }
4126
4127   Newx(esa, NAM$C_MAXRSS + 1, char);
4128 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4129   Newx(esal, NAML$C_MAXRSS + 1, char);
4130 #endif
4131   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4132
4133   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4134     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4135   }
4136   else {
4137 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4138     Newx(outbufl, VMS_MAXRSS, char);
4139     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4140 #else
4141     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4142 #endif
4143   }
4144
4145 #ifdef NAM$M_NO_SHORT_UPCASE
4146   if (decc_efs_case_preserve)
4147     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4148 #endif
4149
4150   /* First attempt to parse as an existing file */
4151   retsts = sys$parse(&myfab,0,0);
4152   if (!(retsts & STS$K_SUCCESS)) {
4153
4154     /* Could not find the file, try as syntax only if error is not fatal */
4155     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4156     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4157       retsts = sys$parse(&myfab,0,0);
4158       if (retsts & STS$K_SUCCESS) goto expanded;
4159     }
4160
4161      /* Still could not parse the file specification */
4162     /*----------------------------------------------*/
4163     sts = rms_free_search_context(&myfab); /* Free search context */
4164     if (out) Safefree(out);
4165     if (tmpfspec != NULL)
4166         Safefree(tmpfspec);
4167     if (vmsfspec != NULL)
4168         Safefree(vmsfspec);
4169     Safefree(esa);
4170     Safefree(esal);
4171     set_vaxc_errno(retsts);
4172     if      (retsts == RMS$_PRV) set_errno(EACCES);
4173     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4174     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4175     else                         set_errno(EVMSERR);
4176     return NULL;
4177   }
4178   retsts = sys$search(&myfab,0,0);
4179   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4180     sts = rms_free_search_context(&myfab); /* Free search context */
4181     if (out) Safefree(out);
4182     if (tmpfspec != NULL)
4183         Safefree(tmpfspec);
4184     if (vmsfspec != NULL)
4185         Safefree(vmsfspec);
4186     Safefree(esa);
4187     Safefree(esal);
4188     set_vaxc_errno(retsts);
4189     if      (retsts == RMS$_PRV) set_errno(EACCES);
4190     else                         set_errno(EVMSERR);
4191     return NULL;
4192   }
4193
4194   /* If the input filespec contained any lowercase characters,
4195    * downcase the result for compatibility with Unix-minded code. */
4196   expanded:
4197   if (!decc_efs_case_preserve) {
4198     for (out = rms_get_fna(myfab, mynam); *out; out++)
4199       if (islower(*out)) { haslower = 1; break; }
4200   }
4201
4202    /* Is a long or a short name expected */
4203   /*------------------------------------*/
4204   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4205     if (rms_nam_rsll(mynam)) {
4206         out = outbuf;
4207         speclen = rms_nam_rsll(mynam);
4208     }
4209     else {
4210         out = esal; /* Not esa */
4211         speclen = rms_nam_esll(mynam);
4212     }
4213   }
4214   else {
4215     if (rms_nam_rsl(mynam)) {
4216         out = outbuf;
4217         speclen = rms_nam_rsl(mynam);
4218     }
4219     else {
4220         out = esa; /* Not esal */
4221         speclen = rms_nam_esl(mynam);
4222     }
4223   }
4224   /* Trim off null fields added by $PARSE
4225    * If type > 1 char, must have been specified in original or default spec
4226    * (not true for version; $SEARCH may have added version of existing file).
4227    */
4228   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4229   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4230     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4231              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4232   }
4233   else {
4234     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4235              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4236   }
4237   if (trimver || trimtype) {
4238     if (defspec && *defspec) {
4239       char *defesal = NULL;
4240       Newx(defesal, NAML$C_MAXRSS + 1, char);
4241       if (defesal != NULL) {
4242         struct FAB deffab = cc$rms_fab;
4243         rms_setup_nam(defnam);
4244
4245         rms_bind_fab_nam(deffab, defnam);
4246
4247         /* Cast ok */
4248         rms_set_fna
4249             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4250
4251         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4252
4253         rms_set_nam_nop(defnam, 0);
4254         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4255 #ifdef NAM$M_NO_SHORT_UPCASE
4256         if (decc_efs_case_preserve)
4257           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4258 #endif
4259         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4260           if (trimver) {
4261              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4262           }
4263           if (trimtype) {
4264             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4265           }
4266         }
4267         Safefree(defesal);
4268       }
4269     }
4270     if (trimver) {
4271       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4272         if (*(rms_nam_verl(mynam)) != '\"')
4273           speclen = rms_nam_verl(mynam) - out;
4274       }
4275       else {
4276         if (*(rms_nam_ver(mynam)) != '\"')
4277           speclen = rms_nam_ver(mynam) - out;
4278       }
4279     }
4280     if (trimtype) {
4281       /* If we didn't already trim version, copy down */
4282       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4283         if (speclen > rms_nam_verl(mynam) - out)
4284           memmove
4285            (rms_nam_typel(mynam),
4286             rms_nam_verl(mynam),
4287             speclen - (rms_nam_verl(mynam) - out));
4288           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4289       }
4290       else {
4291         if (speclen > rms_nam_ver(mynam) - out)
4292           memmove
4293            (rms_nam_type(mynam),
4294             rms_nam_ver(mynam),
4295             speclen - (rms_nam_ver(mynam) - out));
4296           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4297       }
4298     }
4299   }
4300
4301    /* Done with these copies of the input files */
4302   /*-------------------------------------------*/
4303   if (vmsfspec != NULL)
4304         Safefree(vmsfspec);
4305   if (tmpfspec != NULL)
4306         Safefree(tmpfspec);
4307
4308   /* If we just had a directory spec on input, $PARSE "helpfully"
4309    * adds an empty name and type for us */
4310   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4311     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4312         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4313         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4314       speclen = rms_nam_namel(mynam) - out;
4315   }
4316   else {
4317     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4318         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4319         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4320       speclen = rms_nam_name(mynam) - out;
4321   }
4322
4323   /* Posix format specifications must have matching quotes */
4324   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4325     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4326       out[speclen] = '\"';
4327       speclen++;
4328     }
4329   }
4330   out[speclen] = '\0';
4331   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4332
4333   /* Have we been working with an expanded, but not resultant, spec? */
4334   /* Also, convert back to Unix syntax if necessary. */
4335
4336   if (!rms_nam_rsll(mynam)) {
4337     if (isunix) {
4338       if (do_tounixspec(esa,outbuf,0) == NULL) {
4339         Safefree(esal);
4340         Safefree(esa);
4341         return NULL;
4342       }
4343     }
4344     else strcpy(outbuf,esa);
4345   }
4346   else if (isunix) {
4347     Newx(tmpfspec, VMS_MAXRSS, char);
4348     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4349         Safefree(esa);
4350         Safefree(esal);
4351         Safefree(tmpfspec);
4352         return NULL;
4353     }
4354     strcpy(outbuf,tmpfspec);
4355     Safefree(tmpfspec);
4356   }
4357
4358   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4359   sts = rms_free_search_context(&myfab); /* Free search context */
4360   Safefree(esa);
4361   Safefree(esal);
4362   return outbuf;
4363 }
4364 #endif
4365 /*}}}*/
4366 /* External entry points */
4367 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4368 { return do_rmsexpand(spec,buf,0,def,opt); }
4369 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4370 { return do_rmsexpand(spec,buf,1,def,opt); }
4371
4372
4373 /*
4374 ** The following routines are provided to make life easier when
4375 ** converting among VMS-style and Unix-style directory specifications.
4376 ** All will take input specifications in either VMS or Unix syntax. On
4377 ** failure, all return NULL.  If successful, the routines listed below
4378 ** return a pointer to a buffer containing the appropriately
4379 ** reformatted spec (and, therefore, subsequent calls to that routine
4380 ** will clobber the result), while the routines of the same names with
4381 ** a _ts suffix appended will return a pointer to a mallocd string
4382 ** containing the appropriately reformatted spec.
4383 ** In all cases, only explicit syntax is altered; no check is made that
4384 ** the resulting string is valid or that the directory in question
4385 ** actually exists.
4386 **
4387 **   fileify_dirspec() - convert a directory spec into the name of the
4388 **     directory file (i.e. what you can stat() to see if it's a dir).
4389 **     The style (VMS or Unix) of the result is the same as the style
4390 **     of the parameter passed in.
4391 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4392 **     what you prepend to a filename to indicate what directory it's in).
4393 **     The style (VMS or Unix) of the result is the same as the style
4394 **     of the parameter passed in.
4395 **   tounixpath() - convert a directory spec into a Unix-style path.
4396 **   tovmspath() - convert a directory spec into a VMS-style path.
4397 **   tounixspec() - convert any file spec into a Unix-style file spec.
4398 **   tovmsspec() - convert any file spec into a VMS-style spec.
4399 **
4400 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4401 ** Permission is given to distribute this code as part of the Perl
4402 ** standard distribution under the terms of the GNU General Public
4403 ** License or the Perl Artistic License.  Copies of each may be
4404 ** found in the Perl standard distribution.
4405  */
4406
4407 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4408 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4409 {
4410     static char __fileify_retbuf[VMS_MAXRSS];
4411     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4412     char *retspec, *cp1, *cp2, *lastdir;
4413     char *trndir, *vmsdir;
4414     unsigned short int trnlnm_iter_count;
4415     int sts;
4416
4417     if (!dir || !*dir) {
4418       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4419     }
4420     dirlen = strlen(dir);
4421     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4422     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4423       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4424         dir = "/sys$disk";
4425         dirlen = 9;
4426       }
4427       else
4428         dirlen = 1;
4429     }
4430     if (dirlen > (VMS_MAXRSS - 1)) {
4431       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4432       return NULL;
4433     }
4434     Newx(trndir, VMS_MAXRSS + 1, char);
4435     if (!strpbrk(dir+1,"/]>:")  &&
4436         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4437       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4438       trnlnm_iter_count = 0;
4439       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4440         trnlnm_iter_count++;
4441         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4442       }
4443       dirlen = strlen(trndir);
4444     }
4445     else {
4446       strncpy(trndir,dir,dirlen);
4447       trndir[dirlen] = '\0';
4448     }
4449
4450     /* At this point we are done with *dir and use *trndir which is a
4451      * copy that can be modified.  *dir must not be modified.
4452      */
4453
4454     /* If we were handed a rooted logical name or spec, treat it like a
4455      * simple directory, so that
4456      *    $ Define myroot dev:[dir.]
4457      *    ... do_fileify_dirspec("myroot",buf,1) ...
4458      * does something useful.
4459      */
4460     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4461       trndir[--dirlen] = '\0';
4462       trndir[dirlen-1] = ']';
4463     }
4464     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4465       trndir[--dirlen] = '\0';
4466       trndir[dirlen-1] = '>';
4467     }
4468
4469     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4470       /* If we've got an explicit filename, we can just shuffle the string. */
4471       if (*(cp1+1)) hasfilename = 1;
4472       /* Similarly, we can just back up a level if we've got multiple levels
4473          of explicit directories in a VMS spec which ends with directories. */
4474       else {
4475         for (cp2 = cp1; cp2 > trndir; cp2--) {
4476           if (*cp2 == '.') {
4477             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4478               *cp2 = *cp1; *cp1 = '\0';
4479               hasfilename = 1;
4480               break;
4481             }
4482           }
4483           if (*cp2 == '[' || *cp2 == '<') break;
4484         }
4485       }
4486     }
4487
4488     Newx(vmsdir, VMS_MAXRSS + 1, char);
4489     cp1 = strpbrk(trndir,"]:>");
4490     if (hasfilename || !cp1) { /* Unix-style path or filename */
4491       if (trndir[0] == '.') {
4492         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4493           Safefree(trndir);
4494           Safefree(vmsdir);
4495           return do_fileify_dirspec("[]",buf,ts);
4496         }
4497         else if (trndir[1] == '.' &&
4498                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4499           Safefree(trndir);
4500           Safefree(vmsdir);
4501           return do_fileify_dirspec("[-]",buf,ts);
4502         }
4503       }
4504       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4505         dirlen -= 1;                 /* to last element */
4506         lastdir = strrchr(trndir,'/');
4507       }
4508       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4509         /* If we have "/." or "/..", VMSify it and let the VMS code
4510          * below expand it, rather than repeating the code to handle
4511          * relative components of a filespec here */
4512         do {
4513           if (*(cp1+2) == '.') cp1++;
4514           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4515             char * ret_chr;
4516             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4517                 Safefree(trndir);
4518                 Safefree(vmsdir);
4519                 return NULL;
4520             }
4521             if (strchr(vmsdir,'/') != NULL) {
4522               /* If do_tovmsspec() returned it, it must have VMS syntax
4523                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4524                * the time to check this here only so we avoid a recursion
4525                * loop; otherwise, gigo.
4526                */
4527               Safefree(trndir);
4528               Safefree(vmsdir);
4529               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4530               return NULL;
4531             }
4532             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4533                 Safefree(trndir);
4534                 Safefree(vmsdir);
4535                 return NULL;
4536             }
4537             ret_chr = do_tounixspec(trndir,buf,ts);
4538             Safefree(trndir);
4539             Safefree(vmsdir);
4540             return ret_chr;
4541           }
4542           cp1++;
4543         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4544         lastdir = strrchr(trndir,'/');
4545       }
4546       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4547         char * ret_chr;
4548         /* Ditto for specs that end in an MFD -- let the VMS code
4549          * figure out whether it's a real device or a rooted logical. */
4550
4551         /* This should not happen any more.  Allowing the fake /000000
4552          * in a UNIX pathname causes all sorts of problems when trying
4553          * to run in UNIX emulation.  So the VMS to UNIX conversions
4554          * now remove the fake /000000 directories.
4555          */
4556
4557         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4558         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4559             Safefree(trndir);
4560             Safefree(vmsdir);
4561             return NULL;
4562         }
4563         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4564             Safefree(trndir);
4565             Safefree(vmsdir);
4566             return NULL;
4567         }
4568         ret_chr = do_tounixspec(trndir,buf,ts);
4569         Safefree(trndir);
4570         Safefree(vmsdir);
4571         return ret_chr;
4572       }
4573       else {
4574
4575         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4576              !(lastdir = cp1 = strrchr(trndir,']')) &&
4577              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4578         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4579           int ver; char *cp3;
4580
4581           /* For EFS or ODS-5 look for the last dot */
4582           if (decc_efs_charset) {
4583               cp2 = strrchr(cp1,'.');
4584           }
4585           if (vms_process_case_tolerant) {
4586               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4587                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4588                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4589                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4590                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4591                             (ver || *cp3)))))) {
4592                   Safefree(trndir);
4593                   Safefree(vmsdir);
4594                   set_errno(ENOTDIR);
4595                   set_vaxc_errno(RMS$_DIR);
4596                   return NULL;
4597               }
4598           }
4599           else {
4600               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4601                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4602                   !*(cp2+3) || *(cp2+3) != 'R' ||
4603                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4604                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4605                             (ver || *cp3)))))) {
4606                  Safefree(trndir);
4607                  Safefree(vmsdir);
4608                  set_errno(ENOTDIR);
4609                  set_vaxc_errno(RMS$_DIR);
4610                  return NULL;
4611               }
4612           }
4613           dirlen = cp2 - trndir;
4614         }
4615       }
4616
4617       retlen = dirlen + 6;
4618       if (buf) retspec = buf;
4619       else if (ts) Newx(retspec,retlen+1,char);
4620       else retspec = __fileify_retbuf;
4621       memcpy(retspec,trndir,dirlen);
4622       retspec[dirlen] = '\0';
4623
4624       /* We've picked up everything up to the directory file name.
4625          Now just add the type and version, and we're set. */
4626       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4627         strcat(retspec,".dir;1");
4628       else
4629         strcat(retspec,".DIR;1");
4630       Safefree(trndir);
4631       Safefree(vmsdir);
4632       return retspec;
4633     }
4634     else {  /* VMS-style directory spec */
4635
4636       char *esa, term, *cp;
4637       unsigned long int sts, cmplen, haslower = 0;
4638       unsigned int nam_fnb;
4639       char * nam_type;
4640       struct FAB dirfab = cc$rms_fab;
4641       rms_setup_nam(savnam);
4642       rms_setup_nam(dirnam);
4643
4644       Newx(esa, VMS_MAXRSS + 1, char);
4645       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4646       rms_bind_fab_nam(dirfab, dirnam);
4647       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4648       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4649 #ifdef NAM$M_NO_SHORT_UPCASE
4650       if (decc_efs_case_preserve)
4651         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4652 #endif
4653
4654       for (cp = trndir; *cp; cp++)
4655         if (islower(*cp)) { haslower = 1; break; }
4656       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4657         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4658           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4659           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4660         }
4661         if (!sts) {
4662           Safefree(esa);
4663           Safefree(trndir);
4664           Safefree(vmsdir);
4665           set_errno(EVMSERR);
4666           set_vaxc_errno(dirfab.fab$l_sts);
4667           return NULL;
4668         }
4669       }
4670       else {
4671         savnam = dirnam;
4672         /* Does the file really exist? */
4673         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4674           /* Yes; fake the fnb bits so we'll check type below */
4675         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4676         }
4677         else { /* No; just work with potential name */
4678           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4679           else {
4680             Safefree(esa);
4681             Safefree(trndir);
4682             Safefree(vmsdir);
4683             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4684             sts = rms_free_search_context(&dirfab);
4685             return NULL;
4686           }
4687         }
4688       }
4689       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4690         cp1 = strchr(esa,']');
4691         if (!cp1) cp1 = strchr(esa,'>');
4692         if (cp1) {  /* Should always be true */
4693           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4694           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4695         }
4696       }
4697       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4698         /* Yep; check version while we're at it, if it's there. */
4699         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4700         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4701           /* Something other than .DIR[;1].  Bzzt. */
4702           sts = rms_free_search_context(&dirfab);
4703           Safefree(esa);
4704           Safefree(trndir);
4705           Safefree(vmsdir);
4706           set_errno(ENOTDIR);
4707           set_vaxc_errno(RMS$_DIR);
4708           return NULL;
4709         }
4710       }
4711       esa[rms_nam_esll(dirnam)] = '\0';
4712       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4713         /* They provided at least the name; we added the type, if necessary, */
4714         if (buf) retspec = buf;                            /* in sys$parse() */
4715         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4716         else retspec = __fileify_retbuf;
4717         strcpy(retspec,esa);
4718         sts = rms_free_search_context(&dirfab);
4719         Safefree(trndir);
4720         Safefree(esa);
4721         Safefree(vmsdir);
4722         return retspec;
4723       }
4724       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4725         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4726         *cp1 = '\0';
4727         rms_nam_esll(dirnam) -= 9;
4728       }
4729       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4730       if (cp1 == NULL) { /* should never happen */
4731         sts = rms_free_search_context(&dirfab);
4732         Safefree(trndir);
4733         Safefree(esa);
4734         Safefree(vmsdir);
4735         return NULL;
4736       }
4737       term = *cp1;
4738       *cp1 = '\0';
4739       retlen = strlen(esa);
4740       cp1 = strrchr(esa,'.');
4741       /* ODS-5 directory specifications can have extra "." in them. */
4742       while (cp1 != NULL) {
4743         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4744           break;
4745         else {
4746            cp1--;
4747            while ((cp1 > esa) && (*cp1 != '.'))
4748              cp1--;
4749         }
4750         if (cp1 == esa)
4751           cp1 = NULL;
4752       }
4753
4754       if ((cp1) != NULL) {
4755         /* There's more than one directory in the path.  Just roll back. */
4756         *cp1 = term;
4757         if (buf) retspec = buf;
4758         else if (ts) Newx(retspec,retlen+7,char);
4759         else retspec = __fileify_retbuf;
4760         strcpy(retspec,esa);
4761       }
4762       else {
4763         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4764           /* Go back and expand rooted logical name */
4765           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4766 #ifdef NAM$M_NO_SHORT_UPCASE
4767           if (decc_efs_case_preserve)
4768             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4769 #endif
4770           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4771             sts = rms_free_search_context(&dirfab);
4772             Safefree(esa);
4773             Safefree(trndir);
4774             Safefree(vmsdir);
4775             set_errno(EVMSERR);
4776             set_vaxc_errno(dirfab.fab$l_sts);
4777             return NULL;
4778           }
4779           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4780           if (buf) retspec = buf;
4781           else if (ts) Newx(retspec,retlen+16,char);
4782           else retspec = __fileify_retbuf;
4783           cp1 = strstr(esa,"][");
4784           if (!cp1) cp1 = strstr(esa,"]<");
4785           dirlen = cp1 - esa;
4786           memcpy(retspec,esa,dirlen);
4787           if (!strncmp(cp1+2,"000000]",7)) {
4788             retspec[dirlen-1] = '\0';
4789             /* Not full ODS-5, just extra dots in directories for now */
4790             cp1 = retspec + dirlen - 1;
4791             while (cp1 > retspec)
4792             {
4793               if (*cp1 == '[')
4794                 break;
4795               if (*cp1 == '.') {
4796                 if (*(cp1-1) != '^')
4797                   break;
4798               }
4799               cp1--;
4800             }
4801             if (*cp1 == '.') *cp1 = ']';
4802             else {
4803               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4804               memmove(cp1+1,"000000]",7);
4805             }
4806           }
4807           else {
4808             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4809             retspec[retlen] = '\0';
4810             /* Convert last '.' to ']' */
4811             cp1 = retspec+retlen-1;
4812             while (*cp != '[') {
4813               cp1--;
4814               if (*cp1 == '.') {
4815                 /* Do not trip on extra dots in ODS-5 directories */
4816                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4817                 break;
4818               }
4819             }
4820             if (*cp1 == '.') *cp1 = ']';
4821             else {
4822               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4823               memmove(cp1+1,"000000]",7);
4824             }
4825           }
4826         }
4827         else {  /* This is a top-level dir.  Add the MFD to the path. */
4828           if (buf) retspec = buf;
4829           else if (ts) Newx(retspec,retlen+16,char);
4830           else retspec = __fileify_retbuf;
4831           cp1 = esa;
4832           cp2 = retspec;
4833           while (*cp1 != ':') *(cp2++) = *(cp1++);
4834           strcpy(cp2,":[000000]");
4835           cp1 += 2;
4836           strcpy(cp2+9,cp1);
4837         }
4838       }
4839       sts = rms_free_search_context(&dirfab);
4840       /* We've set up the string up through the filename.  Add the
4841          type and version, and we're done. */
4842       strcat(retspec,".DIR;1");
4843
4844       /* $PARSE may have upcased filespec, so convert output to lower
4845        * case if input contained any lowercase characters. */
4846       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4847       Safefree(trndir);
4848       Safefree(esa);
4849       Safefree(vmsdir);
4850       return retspec;
4851     }
4852 }  /* end of do_fileify_dirspec() */
4853 /*}}}*/
4854 /* External entry points */
4855 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4856 { return do_fileify_dirspec(dir,buf,0); }
4857 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4858 { return do_fileify_dirspec(dir,buf,1); }
4859
4860 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4861 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4862 {
4863     static char __pathify_retbuf[VMS_MAXRSS];
4864     unsigned long int retlen;
4865     char *retpath, *cp1, *cp2, *trndir;
4866     unsigned short int trnlnm_iter_count;
4867     STRLEN trnlen;
4868     int sts;
4869
4870     if (!dir || !*dir) {
4871       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4872     }
4873
4874     Newx(trndir, VMS_MAXRSS, char);
4875     if (*dir) strcpy(trndir,dir);
4876     else getcwd(trndir,VMS_MAXRSS - 1);
4877
4878     trnlnm_iter_count = 0;
4879     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4880            && my_trnlnm(trndir,trndir,0)) {
4881       trnlnm_iter_count++;
4882       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4883       trnlen = strlen(trndir);
4884
4885       /* Trap simple rooted lnms, and return lnm:[000000] */
4886       if (!strcmp(trndir+trnlen-2,".]")) {
4887         if (buf) retpath = buf;
4888         else if (ts) Newx(retpath,strlen(dir)+10,char);
4889         else retpath = __pathify_retbuf;
4890         strcpy(retpath,dir);
4891         strcat(retpath,":[000000]");
4892         Safefree(trndir);
4893         return retpath;
4894       }
4895     }
4896
4897     /* At this point we do not work with *dir, but the copy in
4898      * *trndir that is modifiable.
4899      */
4900
4901     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4902       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4903                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4904         retlen = 2 + (*(trndir+1) != '\0');
4905       else {
4906         if ( !(cp1 = strrchr(trndir,'/')) &&
4907              !(cp1 = strrchr(trndir,']')) &&
4908              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4909         if ((cp2 = strchr(cp1,'.')) != NULL &&
4910             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4911              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4912               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4913               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4914           int ver; char *cp3;
4915
4916           /* For EFS or ODS-5 look for the last dot */
4917           if (decc_efs_charset) {
4918             cp2 = strrchr(cp1,'.');
4919           }
4920           if (vms_process_case_tolerant) {
4921               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4922                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4923                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4924                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4925                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4926                             (ver || *cp3)))))) {
4927                 Safefree(trndir);
4928                 set_errno(ENOTDIR);
4929                 set_vaxc_errno(RMS$_DIR);
4930                 return NULL;
4931               }
4932           }
4933           else {
4934               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4935                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4936                   !*(cp2+3) || *(cp2+3) != 'R' ||
4937                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4938                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4939                             (ver || *cp3)))))) {
4940                 Safefree(trndir);
4941                 set_errno(ENOTDIR);
4942                 set_vaxc_errno(RMS$_DIR);
4943                 return NULL;
4944               }
4945           }
4946           retlen = cp2 - trndir + 1;
4947         }
4948         else {  /* No file type present.  Treat the filename as a directory. */
4949           retlen = strlen(trndir) + 1;
4950         }
4951       }
4952       if (buf) retpath = buf;
4953       else if (ts) Newx(retpath,retlen+1,char);
4954       else retpath = __pathify_retbuf;
4955       strncpy(retpath, trndir, retlen-1);
4956       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4957         retpath[retlen-1] = '/';      /* with '/', add it. */
4958         retpath[retlen] = '\0';
4959       }
4960       else retpath[retlen-1] = '\0';
4961     }
4962     else {  /* VMS-style directory spec */
4963       char *esa, *cp;
4964       unsigned long int sts, cmplen, haslower;
4965       struct FAB dirfab = cc$rms_fab;
4966       int dirlen;
4967       rms_setup_nam(savnam);
4968       rms_setup_nam(dirnam);
4969
4970       /* If we've got an explicit filename, we can just shuffle the string. */
4971       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4972              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4973         if ((cp2 = strchr(cp1,'.')) != NULL) {
4974           int ver; char *cp3;
4975           if (vms_process_case_tolerant) {
4976               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4977                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4978                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4979                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4980                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4981                             (ver || *cp3)))))) {
4982                Safefree(trndir);
4983                set_errno(ENOTDIR);
4984                set_vaxc_errno(RMS$_DIR);
4985                return NULL;
4986              }
4987           }
4988           else {
4989               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4990                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4991                   !*(cp2+3) || *(cp2+3) != 'R' ||
4992                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4993                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4994                             (ver || *cp3)))))) {
4995                Safefree(trndir);
4996                set_errno(ENOTDIR);
4997                set_vaxc_errno(RMS$_DIR);
4998                return NULL;
4999              }
5000           }
5001         }
5002         else {  /* No file type, so just draw name into directory part */
5003           for (cp2 = cp1; *cp2; cp2++) ;
5004         }
5005         *cp2 = *cp1;
5006         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5007         *cp1 = '.';
5008         /* We've now got a VMS 'path'; fall through */
5009       }
5010
5011       dirlen = strlen(trndir);
5012       if (trndir[dirlen-1] == ']' ||
5013           trndir[dirlen-1] == '>' ||
5014           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5015         if (buf) retpath = buf;
5016         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5017         else retpath = __pathify_retbuf;
5018         strcpy(retpath,trndir);
5019         Safefree(trndir);
5020         return retpath;
5021       }
5022       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5023       Newx(esa, VMS_MAXRSS, char);
5024       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5025       rms_bind_fab_nam(dirfab, dirnam);
5026       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5027 #ifdef NAM$M_NO_SHORT_UPCASE
5028       if (decc_efs_case_preserve)
5029           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5030 #endif
5031
5032       for (cp = trndir; *cp; cp++)
5033         if (islower(*cp)) { haslower = 1; break; }
5034
5035       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5036         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5037           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5038           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5039         }
5040         if (!sts) {
5041           Safefree(trndir);
5042           Safefree(esa);
5043           set_errno(EVMSERR);
5044           set_vaxc_errno(dirfab.fab$l_sts);
5045           return NULL;
5046         }
5047       }
5048       else {
5049         savnam = dirnam;
5050         /* Does the file really exist? */
5051         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5052           if (dirfab.fab$l_sts != RMS$_FNF) {
5053             int sts1;
5054             sts1 = rms_free_search_context(&dirfab);
5055             Safefree(trndir);
5056             Safefree(esa);
5057             set_errno(EVMSERR);
5058             set_vaxc_errno(dirfab.fab$l_sts);
5059             return NULL;
5060           }
5061           dirnam = savnam; /* No; just work with potential name */
5062         }
5063       }
5064       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5065         /* Yep; check version while we're at it, if it's there. */
5066         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5067         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5068           int sts2;
5069           /* Something other than .DIR[;1].  Bzzt. */
5070           sts2 = rms_free_search_context(&dirfab);
5071           Safefree(trndir);
5072           Safefree(esa);
5073           set_errno(ENOTDIR);
5074           set_vaxc_errno(RMS$_DIR);
5075           return NULL;
5076         }
5077       }
5078       /* OK, the type was fine.  Now pull any file name into the
5079          directory path. */
5080       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5081       else {
5082         cp1 = strrchr(esa,'>');
5083         *(rms_nam_typel(dirnam)) = '>';
5084       }
5085       *cp1 = '.';
5086       *(rms_nam_typel(dirnam) + 1) = '\0';
5087       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5088       if (buf) retpath = buf;
5089       else if (ts) Newx(retpath,retlen,char);
5090       else retpath = __pathify_retbuf;
5091       strcpy(retpath,esa);
5092       Safefree(esa);
5093       sts = rms_free_search_context(&dirfab);
5094       /* $PARSE may have upcased filespec, so convert output to lower
5095        * case if input contained any lowercase characters. */
5096       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5097     }
5098
5099     Safefree(trndir);
5100     return retpath;
5101 }  /* end of do_pathify_dirspec() */
5102 /*}}}*/
5103 /* External entry points */
5104 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5105 { return do_pathify_dirspec(dir,buf,0); }
5106 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5107 { return do_pathify_dirspec(dir,buf,1); }
5108
5109 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5110 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5111 {
5112   static char __tounixspec_retbuf[VMS_MAXRSS];
5113   char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5114   const char *cp2;
5115   int devlen, dirlen, retlen = VMS_MAXRSS;
5116   int expand = 1; /* guarantee room for leading and trailing slashes */
5117   unsigned short int trnlnm_iter_count;
5118   int cmp_rslt;
5119
5120   if (spec == NULL) return NULL;
5121   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5122   if (buf) rslt = buf;
5123   else if (ts) {
5124     retlen = strlen(spec);
5125     cp1 = strchr(spec,'[');
5126     if (!cp1) cp1 = strchr(spec,'<');
5127     if (cp1) {
5128       for (cp1++; *cp1; cp1++) {
5129         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5130         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5131           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5132       }
5133     }
5134     Newx(rslt,retlen+2+2*expand,char);
5135   }
5136   else rslt = __tounixspec_retbuf;
5137
5138   /* New VMS specific format needs translation
5139    * glob passes filenames with trailing '\n' and expects this preserved.
5140    */
5141   if (decc_posix_compliant_pathnames) {
5142     if (strncmp(spec, "\"^UP^", 5) == 0) {
5143       char * uspec;
5144       char *tunix;
5145       int tunix_len;
5146       int nl_flag;
5147
5148       Newx(tunix, VMS_MAXRSS + 1,char);
5149       strcpy(tunix, spec);
5150       tunix_len = strlen(tunix);
5151       nl_flag = 0;
5152       if (tunix[tunix_len - 1] == '\n') {
5153         tunix[tunix_len - 1] = '\"';
5154         tunix[tunix_len] = '\0';
5155         tunix_len--;
5156         nl_flag = 1;
5157       }
5158       uspec = decc$translate_vms(tunix);
5159       Safefree(tunix);
5160       if ((int)uspec > 0) {
5161         strcpy(rslt,uspec);
5162         if (nl_flag) {
5163           strcat(rslt,"\n");
5164         }
5165         else {
5166           /* If we can not translate it, makemaker wants as-is */
5167           strcpy(rslt, spec);
5168         }
5169         return rslt;
5170       }
5171     }
5172   }
5173
5174   cmp_rslt = 0; /* Presume VMS */
5175   cp1 = strchr(spec, '/');
5176   if (cp1 == NULL)
5177     cmp_rslt = 0;
5178
5179     /* Look for EFS ^/ */
5180     if (decc_efs_charset) {
5181       while (cp1 != NULL) {
5182         cp2 = cp1 - 1;
5183         if (*cp2 != '^') {
5184           /* Found illegal VMS, assume UNIX */
5185           cmp_rslt = 1;
5186           break;
5187         }
5188       cp1++;
5189       cp1 = strchr(cp1, '/');
5190     }
5191   }
5192
5193   /* Look for "." and ".." */
5194   if (decc_filename_unix_report) {
5195     if (spec[0] == '.') {
5196       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5197         cmp_rslt = 1;
5198       }
5199       else {
5200         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5201           cmp_rslt = 1;
5202         }
5203       }
5204     }
5205   }
5206   /* This is already UNIX or at least nothing VMS understands */
5207   if (cmp_rslt) {
5208     strcpy(rslt,spec);
5209     return rslt;
5210   }
5211
5212   cp1 = rslt;
5213   cp2 = spec;
5214   dirend = strrchr(spec,']');
5215   if (dirend == NULL) dirend = strrchr(spec,'>');
5216   if (dirend == NULL) dirend = strchr(spec,':');
5217   if (dirend == NULL) {
5218     strcpy(rslt,spec);
5219     return rslt;
5220   }
5221
5222   /* Special case 1 - sys$posix_root = / */
5223 #if __CRTL_VER >= 70000000
5224   if (!decc_disable_posix_root) {
5225     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5226       *cp1 = '/';
5227       cp1++;
5228       cp2 = cp2 + 15;
5229       }
5230   }
5231 #endif
5232
5233   /* Special case 2 - Convert NLA0: to /dev/null */
5234 #if __CRTL_VER < 70000000
5235   cmp_rslt = strncmp(spec,"NLA0:", 5);
5236   if (cmp_rslt != 0)
5237      cmp_rslt = strncmp(spec,"nla0:", 5);
5238 #else
5239   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5240 #endif
5241   if (cmp_rslt == 0) {
5242     strcpy(rslt, "/dev/null");
5243     cp1 = cp1 + 9;
5244     cp2 = cp2 + 5;
5245     if (spec[6] != '\0') {
5246       cp1[9] == '/';
5247       cp1++;
5248       cp2++;
5249     }
5250   }
5251
5252    /* Also handle special case "SYS$SCRATCH:" */
5253 #if __CRTL_VER < 70000000
5254   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5255   if (cmp_rslt != 0)
5256      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5257 #else
5258   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5259 #endif
5260   if (cmp_rslt == 0) {
5261   int islnm;
5262
5263     islnm = my_trnlnm(tmp, "TMP", 0);
5264     if (!islnm) {
5265       strcpy(rslt, "/tmp");
5266       cp1 = cp1 + 4;
5267       cp2 = cp2 + 12;
5268       if (spec[12] != '\0') {
5269         cp1[4] == '/';
5270         cp1++;
5271         cp2++;
5272       }
5273     }
5274   }
5275
5276   if (*cp2 != '[' && *cp2 != '<') {
5277     *(cp1++) = '/';
5278   }
5279   else {  /* the VMS spec begins with directories */
5280     cp2++;
5281     if (*cp2 == ']' || *cp2 == '>') {
5282       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5283       return rslt;
5284     }
5285     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5286       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5287         if (ts) Safefree(rslt);
5288         return NULL;
5289       }
5290       trnlnm_iter_count = 0;
5291       do {
5292         cp3 = tmp;
5293         while (*cp3 != ':' && *cp3) cp3++;
5294         *(cp3++) = '\0';
5295         if (strchr(cp3,']') != NULL) break;
5296         trnlnm_iter_count++;
5297         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5298       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5299       if (ts && !buf &&
5300           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5301         retlen = devlen + dirlen;
5302         Renew(rslt,retlen+1+2*expand,char);
5303         cp1 = rslt;
5304       }
5305       cp3 = tmp;
5306       *(cp1++) = '/';
5307       while (*cp3) {
5308         *(cp1++) = *(cp3++);
5309         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5310       }
5311       *(cp1++) = '/';
5312     }
5313     if ((*cp2 == '^')) {
5314         /* EFS file escape, pass the next character as is */
5315         /* Fix me: HEX encoding for UNICODE not implemented */
5316         cp2++;
5317     }
5318     else if ( *cp2 == '.') {
5319       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5320         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5321         cp2 += 3;
5322       }
5323       else cp2++;
5324     }
5325   }
5326   for (; cp2 <= dirend; cp2++) {
5327     if ((*cp2 == '^')) {
5328         /* EFS file escape, pass the next character as is */
5329         /* Fix me: HEX encoding for UNICODE not implemented */
5330         cp2++;
5331         *(cp1++) = *cp2;
5332     }
5333     if (*cp2 == ':') {
5334       *(cp1++) = '/';
5335       if (*(cp2+1) == '[') cp2++;
5336     }
5337     else if (*cp2 == ']' || *cp2 == '>') {
5338       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5339     }
5340     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5341       *(cp1++) = '/';
5342       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5343         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5344                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5345         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5346             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5347       }
5348       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5349         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5350         cp2 += 2;
5351       }
5352     }
5353     else if (*cp2 == '-') {
5354       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5355         while (*cp2 == '-') {
5356           cp2++;
5357           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5358         }
5359         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5360           if (ts) Safefree(rslt);                        /* filespecs like */
5361           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5362           return NULL;
5363         }
5364       }
5365       else *(cp1++) = *cp2;
5366     }
5367     else *(cp1++) = *cp2;
5368   }
5369   while (*cp2) *(cp1++) = *(cp2++);
5370   *cp1 = '\0';
5371
5372   /* This still leaves /000000/ when working with a
5373    * VMS device root or concealed root.
5374    */
5375   {
5376   int ulen;
5377   char * zeros;
5378
5379       ulen = strlen(rslt);
5380
5381       /* Get rid of "000000/ in rooted filespecs */
5382       if (ulen > 7) {
5383         zeros = strstr(rslt, "/000000/");
5384         if (zeros != NULL) {
5385           int mlen;
5386           mlen = ulen - (zeros - rslt) - 7;
5387           memmove(zeros, &zeros[7], mlen);
5388           ulen = ulen - 7;
5389           rslt[ulen] = '\0';
5390         }
5391       }
5392   }
5393
5394   return rslt;
5395
5396 }  /* end of do_tounixspec() */
5397 /*}}}*/
5398 /* External entry points */
5399 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5400 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5401
5402 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5403
5404 static int posix_to_vmsspec
5405   (char *vmspath, int vmspath_len, const char *unixpath) {
5406 int sts;
5407 struct FAB myfab = cc$rms_fab;
5408 struct NAML mynam = cc$rms_naml;
5409 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5410  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5411 char *esa;
5412 char *vms_delim;
5413 int dir_flag;
5414 int unixlen;
5415
5416   /* If not a posix spec already, convert it */
5417   dir_flag = 0;
5418   unixlen = strlen(unixpath);
5419   if (unixlen == 0) {
5420     vmspath[0] = '\0';
5421     return SS$_NORMAL;
5422   }
5423   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5424     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5425   }
5426   else {
5427     /* This is already a VMS specification, no conversion */
5428     unixlen--;
5429     strncpy(vmspath,unixpath, vmspath_len);
5430   }
5431   vmspath[vmspath_len] = 0;
5432   if (unixpath[unixlen - 1] == '/')
5433   dir_flag = 1;
5434   Newx(esa, VMS_MAXRSS, char);
5435   myfab.fab$l_fna = vmspath;
5436   myfab.fab$b_fns = strlen(vmspath);
5437   myfab.fab$l_naml = &mynam;
5438   mynam.naml$l_esa = NULL;
5439   mynam.naml$b_ess = 0;
5440   mynam.naml$l_long_expand = esa;
5441   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5442   mynam.naml$l_rsa = NULL;
5443   mynam.naml$b_rss = 0;
5444   if (decc_efs_case_preserve)
5445     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5446   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5447
5448   /* Set up the remaining naml fields */
5449   sts = sys$parse(&myfab);
5450
5451   /* It failed! Try again as a UNIX filespec */
5452   if (!(sts & 1)) {
5453     Safefree(esa);
5454     return sts;
5455   }
5456
5457    /* get the Device ID and the FID */
5458    sts = sys$search(&myfab);
5459    /* on any failure, returned the POSIX ^UP^ filespec */
5460    if (!(sts & 1)) {
5461       Safefree(esa);
5462       return sts;
5463    }
5464    specdsc.dsc$a_pointer = vmspath;
5465    specdsc.dsc$w_length = vmspath_len;
5466
5467    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5468    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5469    sts = lib$fid_to_name
5470       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5471
5472   /* on any failure, returned the POSIX ^UP^ filespec */
5473   if (!(sts & 1)) {
5474      /* This can happen if user does not have permission to read directories */
5475      if (strncmp(unixpath,"\"^UP^",5) != 0)
5476        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5477      else
5478        strcpy(vmspath, unixpath);
5479   }
5480   else {
5481     vmspath[specdsc.dsc$w_length] = 0;
5482
5483     /* Are we expecting a directory? */
5484     if (dir_flag != 0) {
5485     int i;
5486     char *eptr;
5487
5488       eptr = NULL;
5489
5490       i = specdsc.dsc$w_length - 1;
5491       while (i > 0) {
5492       int zercnt;
5493         zercnt = 0;
5494         /* Version must be '1' */
5495         if (vmspath[i--] != '1')
5496           break;
5497         /* Version delimiter is one of ".;" */
5498         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5499           break;
5500         i--;
5501         if (vmspath[i--] != 'R')
5502           break;
5503         if (vmspath[i--] != 'I')
5504           break;
5505         if (vmspath[i--] != 'D')
5506           break;
5507         if (vmspath[i--] != '.')
5508           break;
5509         eptr = &vmspath[i+1];
5510         while (i > 0) {
5511           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5512             if (vmspath[i-1] != '^') {
5513               if (zercnt != 6) {
5514                 *eptr = vmspath[i];
5515                 eptr[1] = '\0';
5516                 vmspath[i] = '.';
5517                 break;
5518               }
5519               else {
5520                 /* Get rid of 6 imaginary zero directory filename */
5521                 vmspath[i+1] = '\0';
5522               }
5523             }
5524           }
5525           if (vmspath[i] == '0')
5526             zercnt++;
5527           else
5528             zercnt = 10;
5529           i--;
5530         }
5531         break;
5532       }
5533     }
5534   }
5535   Safefree(esa);
5536   return sts;
5537 }
5538
5539 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5540 static int posix_to_vmsspec_hardway
5541   (char *vmspath, int vmspath_len, const char *unixpath) {
5542
5543 char *esa;
5544 const char *unixptr;
5545 char *vmsptr;
5546 const char *lastslash;
5547 const char *lastdot;
5548 int unixlen;
5549 int vmslen;
5550 int dir_start;
5551 int dir_dot;
5552 int quoted;
5553
5554
5555   unixptr = unixpath;
5556   dir_dot = 0;
5557
5558   /* Ignore leading "/" characters */
5559   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5560     unixptr++;
5561   }
5562   unixlen = strlen(unixptr);
5563
5564   /* Do nothing with blank paths */
5565   if (unixlen == 0) {
5566     vmspath[0] = '\0';
5567     return SS$_NORMAL;
5568   }
5569
5570   lastslash = strrchr(unixptr,'/');
5571   lastdot = strrchr(unixptr,'.');
5572
5573
5574   /* last dot is last dot or past end of string */
5575   if (lastdot == NULL)
5576     lastdot = unixptr + unixlen;
5577
5578   /* if no directories, set last slash to beginning of string */
5579   if (lastslash == NULL) {
5580     lastslash = unixptr;
5581   }
5582   else {
5583     /* Watch out for trailing "." after last slash, still a directory */
5584     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5585       lastslash = unixptr + unixlen;
5586     }
5587
5588     /* Watch out for traiing ".." after last slash, still a directory */
5589     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5590       lastslash = unixptr + unixlen;
5591     }
5592
5593     /* dots in directories are aways escaped */
5594     if (lastdot < lastslash)
5595       lastdot = unixptr + unixlen;
5596   }
5597
5598   /* if (unixptr < lastslash) then we are in a directory */
5599
5600   dir_start = 0;
5601   quoted = 0;
5602
5603   vmsptr = vmspath;
5604   vmslen = 0;
5605
5606   /* This could have a "^UP^ on the front */
5607   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5608     quoted = 1;
5609     unixptr+= 5;
5610   }
5611
5612   /* Start with the UNIX path */
5613   if (*unixptr != '/') {
5614     /* relative paths */
5615     if (lastslash > unixptr) {
5616     int dotdir_seen;
5617
5618       /* skip leading ./ */
5619       dotdir_seen = 0;
5620       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5621         dotdir_seen = 1;
5622         unixptr++;
5623         unixptr++;
5624       }
5625
5626       /* Are we still in a directory? */
5627       if (unixptr <= lastslash) {
5628         *vmsptr++ = '[';
5629         vmslen = 1;
5630         dir_start = 1;
5631
5632         /* if not backing up, then it is relative forward. */
5633         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5634               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5635           *vmsptr++ = '.';
5636           vmslen++;
5637           dir_dot = 1;
5638         }
5639        }
5640        else {
5641          if (dotdir_seen) {
5642            /* Perl wants an empty directory here to tell the difference
5643             * between a DCL commmand and a filename
5644             */
5645           *vmsptr++ = '[';
5646           *vmsptr++ = ']';
5647           vmslen = 2;
5648         }
5649       }
5650     }
5651     else {
5652       /* Handle two special files . and .. */
5653       if (unixptr[0] == '.') {
5654         if (unixptr[1] == '\0') {
5655           *vmsptr++ = '[';
5656           *vmsptr++ = ']';
5657           vmslen += 2;
5658           *vmsptr++ = '\0';
5659           return SS$_NORMAL;
5660         }
5661         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5662           *vmsptr++ = '[';
5663           *vmsptr++ = '-';
5664           *vmsptr++ = ']';
5665           vmslen += 3;
5666           *vmsptr++ = '\0';
5667           return SS$_NORMAL;
5668         }
5669       }
5670     }
5671   }
5672   else {        /* Absolute PATH handling */
5673   int sts;
5674   char * nextslash;
5675   int seg_len;
5676     /* Need to find out where root is */
5677
5678     /* In theory, this procedure should never get an absolute POSIX pathname
5679      * that can not be found on the POSIX root.
5680      * In practice, that can not be relied on, and things will show up
5681      * here that are a VMS device name or concealed logical name instead.
5682      * So to make things work, this procedure must be tolerant.
5683      */
5684     Newx(esa, vmspath_len, char);
5685
5686     sts = SS$_NORMAL;
5687     nextslash = strchr(&unixptr[1],'/');
5688     seg_len = 0;
5689     if (nextslash != NULL) {
5690       seg_len = nextslash - &unixptr[1];
5691       strncpy(vmspath, unixptr, seg_len + 1);
5692       vmspath[seg_len+1] = 0;
5693       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5694     }
5695
5696     if (sts & 1) {
5697       /* This is verified to be a real path */
5698
5699       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5700       strcpy(vmspath, esa);
5701       vmslen = strlen(vmspath);
5702       vmsptr = vmspath + vmslen;
5703       unixptr++;
5704       if (unixptr < lastslash) {
5705       char * rptr;
5706         vmsptr--;
5707         *vmsptr++ = '.';
5708         dir_start = 1;
5709         dir_dot = 1;
5710         if (vmslen > 7) {
5711         int cmp;
5712           rptr = vmsptr - 7;
5713           cmp = strcmp(rptr,"000000.");
5714           if (cmp == 0) {
5715             vmslen -= 7;
5716             vmsptr -= 7;
5717             vmsptr[1] = '\0';
5718           } /* removing 6 zeros */
5719         } /* vmslen < 7, no 6 zeros possible */
5720       } /* Not in a directory */
5721     } /* end of verified real path handling */
5722     else {
5723     int add_6zero;
5724     int islnm;
5725
5726       /* Ok, we have a device or a concealed root that is not in POSIX
5727        * or we have garbage.  Make the best of it.
5728        */
5729
5730       /* Posix to VMS destroyed this, so copy it again */
5731       strncpy(vmspath, &unixptr[1], seg_len);
5732       vmspath[seg_len] = 0;
5733       vmslen = seg_len;
5734       vmsptr = &vmsptr[vmslen];
5735       islnm = 0;
5736
5737       /* Now do we need to add the fake 6 zero directory to it? */
5738       add_6zero = 1;
5739       if ((*lastslash == '/') && (nextslash < lastslash)) {
5740         /* No there is another directory */
5741         add_6zero = 0;
5742       }
5743       else {
5744       int trnend;
5745
5746         /* now we have foo:bar or foo:[000000]bar to decide from */
5747         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5748         trnend = islnm ? islnm - 1 : 0;
5749
5750         /* if this was a logical name, ']' or '>' must be present */
5751         /* if not a logical name, then assume a device and hope. */
5752         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5753
5754         /* if log name and trailing '.' then rooted - treat as device */
5755         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5756
5757         /* Fix me, if not a logical name, a device lookup should be
5758          * done to see if the device is file structured.  If the device
5759          * is not file structured, the 6 zeros should not be put on.
5760          *
5761          * As it is, perl is occasionally looking for dev:[000000]tty.
5762          * which looks a little strange.
5763          */
5764
5765         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5766           /* No real directory present */
5767           add_6zero = 1;
5768         }
5769       }
5770
5771       /* Put the device delimiter on */
5772       *vmsptr++ = ':';
5773       vmslen++;
5774       unixptr = nextslash;
5775       unixptr++;
5776
5777       /* Start directory if needed */
5778       if (!islnm || add_6zero) {
5779         *vmsptr++ = '[';
5780         vmslen++;
5781         dir_start = 1;
5782       }
5783
5784       /* add fake 000000] if needed */
5785       if (add_6zero) {
5786         *vmsptr++ = '0';
5787         *vmsptr++ = '0';
5788         *vmsptr++ = '0';
5789         *vmsptr++ = '0';
5790         *vmsptr++ = '0';
5791         *vmsptr++ = '0';
5792         *vmsptr++ = ']';
5793         vmslen += 7;
5794         dir_start = 0;
5795       }
5796
5797     } /* non-POSIX translation */
5798     Safefree(esa);
5799   } /* End of relative/absolute path handling */
5800
5801   while ((*unixptr) && (vmslen < vmspath_len)){
5802   int dash_flag;
5803
5804     dash_flag = 0;
5805
5806     if (dir_start != 0) {
5807
5808       /* First characters in a directory are handled special */
5809       while ((*unixptr == '/') ||
5810              ((*unixptr == '.') &&
5811               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5812       int loop_flag;
5813
5814         loop_flag = 0;
5815
5816         /* Skip redundant / in specification */
5817         while ((*unixptr == '/') && (dir_start != 0)) {
5818           loop_flag = 1;
5819           unixptr++;
5820           if (unixptr == lastslash)
5821             break;
5822         }
5823         if (unixptr == lastslash)
5824           break;
5825
5826         /* Skip redundant ./ characters */
5827         while ((*unixptr == '.') &&
5828                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5829           loop_flag = 1;
5830           unixptr++;
5831           if (unixptr == lastslash)
5832             break;
5833           if (*unixptr == '/')
5834             unixptr++;
5835         }
5836         if (unixptr == lastslash)
5837           break;
5838
5839         /* Skip redundant ../ characters */
5840         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5841              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5842           /* Set the backing up flag */
5843           loop_flag = 1;
5844           dir_dot = 0;
5845           dash_flag = 1;
5846           *vmsptr++ = '-';
5847           vmslen++;
5848           unixptr++; /* first . */
5849           unixptr++; /* second . */
5850           if (unixptr == lastslash)
5851             break;
5852           if (*unixptr == '/') /* The slash */
5853             unixptr++;
5854         }
5855         if (unixptr == lastslash)
5856           break;
5857
5858         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5859         /* Not needed when VMS is pretending to be UNIX. */
5860
5861         /* Is this loop stuck because of too many dots? */
5862         if (loop_flag == 0) {
5863           /* Exit the loop and pass the rest through */
5864           break;
5865         }
5866       }
5867
5868       /* Are we done with directories yet? */
5869       if (unixptr >= lastslash) {
5870
5871         /* Watch out for trailing dots */
5872         if (dir_dot != 0) {
5873             vmslen --;
5874             vmsptr--;
5875         }
5876         *vmsptr++ = ']';
5877         vmslen++;
5878         dash_flag = 0;
5879         dir_start = 0;
5880         if (*unixptr == '/')
5881           unixptr++;
5882       }
5883       else {
5884         /* Have we stopped backing up? */
5885         if (dash_flag) {
5886           *vmsptr++ = '.';
5887           vmslen++;
5888           dash_flag = 0;
5889           /* dir_start continues to be = 1 */
5890         }
5891         if (*unixptr == '-') {
5892           *vmsptr++ = '^';
5893           *vmsptr++ = *unixptr++;
5894           vmslen += 2;
5895           dir_start = 0;
5896
5897           /* Now are we done with directories yet? */
5898           if (unixptr >= lastslash) {
5899
5900             /* Watch out for trailing dots */
5901             if (dir_dot != 0) {
5902               vmslen --;
5903               vmsptr--;
5904             }
5905
5906             *vmsptr++ = ']';
5907             vmslen++;
5908             dash_flag = 0;
5909             dir_start = 0;
5910           }
5911         }
5912       }
5913     }
5914
5915     /* All done? */
5916     if (*unixptr == '\0')
5917       break;
5918
5919     /* Normal characters - More EFS work probably needed */
5920     dir_start = 0;
5921     dir_dot = 0;
5922
5923     switch(*unixptr) {
5924     case '/':
5925         /* remove multiple / */
5926         while (unixptr[1] == '/') {
5927            unixptr++;
5928         }
5929         if (unixptr == lastslash) {
5930           /* Watch out for trailing dots */
5931           if (dir_dot != 0) {
5932             vmslen --;
5933             vmsptr--;
5934           }
5935           *vmsptr++ = ']';
5936         }
5937         else {
5938           dir_start = 1;
5939           *vmsptr++ = '.';
5940           dir_dot = 1;
5941
5942           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5943           /* Not needed when VMS is pretending to be UNIX. */
5944
5945         }
5946         dash_flag = 0;
5947         if (*unixptr != '\0')
5948           unixptr++;
5949         vmslen++;
5950         break;
5951     case '?':
5952         *vmsptr++ = '%';
5953         vmslen++;
5954         unixptr++;
5955         break;
5956     case ' ':
5957         *vmsptr++ = '^';
5958         *vmsptr++ = '_';
5959         vmslen += 2;
5960         unixptr++;
5961         break;
5962     case '.':
5963         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5964           *vmsptr++ = '^';
5965           *vmsptr++ = '.';
5966           vmslen += 2;
5967           unixptr++;
5968
5969           /* trailing dot ==> '^..' on VMS */
5970           if (*unixptr == '\0') {
5971             *vmsptr++ = '.';
5972             vmslen++;
5973           }
5974           *vmsptr++ = *unixptr++;
5975           vmslen ++;
5976         }
5977         if (quoted && (unixptr[1] == '\0')) {
5978           unixptr++;
5979           break;
5980         }
5981         *vmsptr++ = '^';
5982         *vmsptr++ = *unixptr++;
5983         vmslen += 2;
5984         break;
5985     case '~':
5986     case ';':
5987     case '\\':
5988         *vmsptr++ = '^';
5989         *vmsptr++ = *unixptr++;
5990         vmslen += 2;
5991         break;
5992     default:
5993         if (*unixptr != '\0') {
5994           *vmsptr++ = *unixptr++;
5995           vmslen++;
5996         }
5997         break;
5998     }
5999   }
6000
6001   /* Make sure directory is closed */
6002   if (unixptr == lastslash) {
6003     char *vmsptr2;
6004     vmsptr2 = vmsptr - 1;
6005
6006     if (*vmsptr2 != ']') {
6007       *vmsptr2--;
6008
6009       /* directories do not end in a dot bracket */
6010       if (*vmsptr2 == '.') {
6011         vmsptr2--;
6012
6013         /* ^. is allowed */
6014         if (*vmsptr2 != '^') {
6015           vmsptr--; /* back up over the dot */
6016         }
6017       }
6018       *vmsptr++ = ']';
6019     }
6020   }
6021   else {
6022     char *vmsptr2;
6023     /* Add a trailing dot if a file with no extension */
6024     vmsptr2 = vmsptr - 1;
6025     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6026         (*lastdot != '.')) {
6027         *vmsptr++ = '.';
6028         vmslen++;
6029     }
6030   }
6031
6032   *vmsptr = '\0';
6033   return SS$_NORMAL;
6034 }
6035 #endif
6036
6037 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6038 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6039   static char __tovmsspec_retbuf[VMS_MAXRSS];
6040   char *rslt, *dirend;
6041   char *lastdot;
6042   char *vms_delim;
6043   register char *cp1;
6044   const char *cp2;
6045   unsigned long int infront = 0, hasdir = 1;
6046   int rslt_len;
6047   int no_type_seen;
6048
6049   if (path == NULL) return NULL;
6050   rslt_len = VMS_MAXRSS;
6051   if (buf) rslt = buf;
6052   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6053   else rslt = __tovmsspec_retbuf;
6054   if (strpbrk(path,"]:>") ||
6055       (dirend = strrchr(path,'/')) == NULL) {
6056     if (path[0] == '.') {
6057       if (path[1] == '\0') strcpy(rslt,"[]");
6058       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6059       else strcpy(rslt,path); /* probably garbage */
6060     }
6061     else strcpy(rslt,path);
6062     return rslt;
6063   }
6064
6065    /* Posix specifications are now a native VMS format */
6066   /*--------------------------------------------------*/
6067 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6068   if (decc_posix_compliant_pathnames) {
6069     if (strncmp(path,"\"^UP^",5) == 0) {
6070       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6071       return rslt;
6072     }
6073   }
6074 #endif
6075
6076   vms_delim = strpbrk(path,"]:>");
6077
6078   if ((vms_delim != NULL) ||
6079       ((dirend = strrchr(path,'/')) == NULL)) {
6080
6081     /* VMS special characters found! */
6082
6083     if (path[0] == '.') {
6084       if (path[1] == '\0') strcpy(rslt,"[]");
6085       else if (path[1] == '.' && path[2] == '\0')
6086         strcpy(rslt,"[-]");
6087
6088       /* Dot preceeding a device or directory ? */
6089       else {
6090         /* If not in POSIX mode, pass it through and hope it works */
6091 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6092         if (!decc_posix_compliant_pathnames)
6093           strcpy(rslt,path); /* probably garbage */
6094         else
6095           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6096 #else
6097         strcpy(rslt,path); /* probably garbage */
6098 #endif
6099       }
6100     }
6101     else {
6102
6103        /* If no VMS characters and in POSIX mode, convert it!
6104         * This is the easiest way to get directory specifications
6105         * handled correctly in POSIX mode
6106         */
6107 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6108       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6109         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6110       else {
6111         /* No unix path separators - presume VMS already */
6112         strcpy(rslt,path);
6113       }
6114 #else
6115       strcpy(rslt,path); /* probably garbage */
6116 #endif
6117     }
6118     return rslt;
6119   }
6120
6121 /* If POSIX mode active, handle the conversion */
6122 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6123   if (decc_posix_compliant_pathnames) {
6124     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6125     return rslt;
6126   }
6127 #endif
6128
6129   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6130     if (!*(dirend+2)) dirend +=2;
6131     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6132     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6133   }
6134
6135   cp1 = rslt;
6136   cp2 = path;
6137   lastdot = strrchr(cp2,'.');
6138   if (*cp2 == '/') {
6139     char *trndev;
6140     int islnm, rooted;
6141     STRLEN trnend;
6142
6143     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6144     if (!*(cp2+1)) {
6145       if (decc_disable_posix_root) {
6146         strcpy(rslt,"sys$disk:[000000]");
6147       }
6148       else {
6149         strcpy(rslt,"sys$posix_root:[000000]");
6150       }
6151       return rslt;
6152     }
6153     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6154     *cp1 = '\0';
6155     Newx(trndev, VMS_MAXRSS, char);
6156     islnm =  my_trnlnm(rslt,trndev,0);
6157
6158      /* DECC special handling */
6159     if (!islnm) {
6160       if (strcmp(rslt,"bin") == 0) {
6161         strcpy(rslt,"sys$system");
6162         cp1 = rslt + 10;
6163         *cp1 = 0;
6164         islnm =  my_trnlnm(rslt,trndev,0);
6165       }
6166       else if (strcmp(rslt,"tmp") == 0) {
6167         strcpy(rslt,"sys$scratch");
6168         cp1 = rslt + 11;
6169         *cp1 = 0;
6170         islnm =  my_trnlnm(rslt,trndev,0);
6171       }
6172       else if (!decc_disable_posix_root) {
6173         strcpy(rslt, "sys$posix_root");
6174         cp1 = rslt + 13;
6175         *cp1 = 0;
6176         cp2 = path;
6177         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6178         islnm =  my_trnlnm(rslt,trndev,0);
6179       }
6180       else if (strcmp(rslt,"dev") == 0) {
6181         if (strncmp(cp2,"/null", 5) == 0) {
6182           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6183             strcpy(rslt,"NLA0");
6184             cp1 = rslt + 4;
6185             *cp1 = 0;
6186             cp2 = cp2 + 5;
6187             islnm =  my_trnlnm(rslt,trndev,0);
6188           }
6189         }
6190       }
6191     }
6192
6193     trnend = islnm ? strlen(trndev) - 1 : 0;
6194     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6195     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6196     /* If the first element of the path is a logical name, determine
6197      * whether it has to be translated so we can add more directories. */
6198     if (!islnm || rooted) {
6199       *(cp1++) = ':';
6200       *(cp1++) = '[';
6201       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6202       else cp2++;
6203     }
6204     else {
6205       if (cp2 != dirend) {
6206         strcpy(rslt,trndev);
6207         cp1 = rslt + trnend;
6208         if (*cp2 != 0) {
6209           *(cp1++) = '.';
6210           cp2++;
6211         }
6212       }
6213       else {
6214         if (decc_disable_posix_root) {
6215           *(cp1++) = ':';
6216           hasdir = 0;
6217         }
6218       }
6219     }
6220     Safefree(trndev);
6221   }
6222   else {
6223     *(cp1++) = '[';
6224     if (*cp2 == '.') {
6225       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6226         cp2 += 2;         /* skip over "./" - it's redundant */
6227         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6228       }
6229       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6230         *(cp1++) = '-';                                 /* "../" --> "-" */
6231         cp2 += 3;
6232       }
6233       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6234                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6235         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6236         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6237         cp2 += 4;
6238       }
6239       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6240         /* Escape the extra dots in EFS file specifications */
6241         *(cp1++) = '^';
6242       }
6243       if (cp2 > dirend) cp2 = dirend;
6244     }
6245     else *(cp1++) = '.';
6246   }
6247   for (; cp2 < dirend; cp2++) {
6248     if (*cp2 == '/') {
6249       if (*(cp2-1) == '/') continue;
6250       if (*(cp1-1) != '.') *(cp1++) = '.';
6251       infront = 0;
6252     }
6253     else if (!infront && *cp2 == '.') {
6254       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6255       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6256       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6257         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6258         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6259         else {  /* back up over previous directory name */
6260           cp1--;
6261           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6262           if (*(cp1-1) == '[') {
6263             memcpy(cp1,"000000.",7);
6264             cp1 += 7;
6265           }
6266         }
6267         cp2 += 2;
6268         if (cp2 == dirend) break;
6269       }
6270       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6271                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6272         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6273         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6274         if (!*(cp2+3)) {
6275           *(cp1++) = '.';  /* Simulate trailing '/' */
6276           cp2 += 2;  /* for loop will incr this to == dirend */
6277         }
6278         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6279       }
6280       else {
6281         if (decc_efs_charset == 0)
6282           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6283         else {
6284           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6285           *(cp1++) = '.';
6286         }
6287       }
6288     }
6289     else {
6290       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6291       if (*cp2 == '.') {
6292         if (decc_efs_charset == 0)
6293           *(cp1++) = '_';
6294         else {
6295           *(cp1++) = '^';
6296           *(cp1++) = '.';
6297         }
6298       }
6299       else                  *(cp1++) =  *cp2;
6300       infront = 1;
6301     }
6302   }
6303   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6304   if (hasdir) *(cp1++) = ']';
6305   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6306   /* fixme for ODS5 */
6307   no_type_seen = 0;
6308   if (cp2 > lastdot)
6309     no_type_seen = 1;
6310   while (*cp2) {
6311     switch(*cp2) {
6312     case '?':
6313         *(cp1++) = '%';
6314         cp2++;
6315     case ' ':
6316         *(cp1)++ = '^';
6317         *(cp1)++ = '_';
6318         cp2++;
6319         break;
6320     case '.':
6321         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6322             decc_readdir_dropdotnotype) {
6323           *(cp1)++ = '^';
6324           *(cp1)++ = '.';
6325           cp2++;
6326
6327           /* trailing dot ==> '^..' on VMS */
6328           if (*cp2 == '\0') {
6329             *(cp1++) = '.';
6330             no_type_seen = 0;
6331           }
6332         }
6333         else {
6334           *(cp1++) = *(cp2++);
6335           no_type_seen = 0;
6336         }
6337         break;
6338     case '\"':
6339     case '~':
6340     case '`':
6341     case '!':
6342     case '#':
6343     case '%':
6344     case '^':
6345     case '&':
6346     case '(':
6347     case ')':
6348     case '=':
6349     case '+':
6350     case '\'':
6351     case '@':
6352     case '[':
6353     case ']':
6354     case '{':
6355     case '}':
6356     case ':':
6357     case '\\':
6358     case '|':
6359     case '<':
6360     case '>':
6361         *(cp1++) = '^';
6362         *(cp1++) = *(cp2++);
6363         break;
6364     case ';':
6365         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6366          * which is wrong.  UNIX notation should be ".dir. unless
6367          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6368          * changing this behavior could break more things at this time.
6369          * efs character set effectively does not allow "." to be a version
6370          * delimiter as a further complication about changing this.
6371          */
6372         if (decc_filename_unix_report != 0) {
6373           *(cp1++) = '^';
6374         }
6375         *(cp1++) = *(cp2++);
6376         break;
6377     default:
6378         *(cp1++) = *(cp2++);
6379     }
6380   }
6381   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6382   char *lcp1;
6383     lcp1 = cp1;
6384     lcp1--;
6385      /* Fix me for "^]", but that requires making sure that you do
6386       * not back up past the start of the filename
6387       */
6388     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6389       *cp1++ = '.';
6390   }
6391   *cp1 = '\0';
6392
6393   return rslt;
6394
6395 }  /* end of do_tovmsspec() */
6396 /*}}}*/
6397 /* External entry points */
6398 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6399 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6400
6401 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6402 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6403   static char __tovmspath_retbuf[VMS_MAXRSS];
6404   int vmslen;
6405   char *pathified, *vmsified, *cp;
6406
6407   if (path == NULL) return NULL;
6408   Newx(pathified, VMS_MAXRSS, char);
6409   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6410     Safefree(pathified);
6411     return NULL;
6412   }
6413   Newx(vmsified, VMS_MAXRSS, char);
6414   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6415     Safefree(pathified);
6416     Safefree(vmsified);
6417     return NULL;
6418   }
6419   Safefree(pathified);
6420   if (buf) {
6421     Safefree(vmsified);
6422     return buf;
6423   }
6424   else if (ts) {
6425     vmslen = strlen(vmsified);
6426     Newx(cp,vmslen+1,char);
6427     memcpy(cp,vmsified,vmslen);
6428     cp[vmslen] = '\0';
6429     Safefree(vmsified);
6430     return cp;
6431   }
6432   else {
6433     strcpy(__tovmspath_retbuf,vmsified);
6434     Safefree(vmsified);
6435     return __tovmspath_retbuf;
6436   }
6437
6438 }  /* end of do_tovmspath() */
6439 /*}}}*/
6440 /* External entry points */
6441 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6442 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6443
6444
6445 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6446 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6447   static char __tounixpath_retbuf[VMS_MAXRSS];
6448   int unixlen;
6449   char *pathified, *unixified, *cp;
6450
6451   if (path == NULL) return NULL;
6452   Newx(pathified, VMS_MAXRSS, char);
6453   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6454     Safefree(pathified);
6455     return NULL;
6456   }
6457   Newx(unixified, VMS_MAXRSS, char);
6458   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6459     Safefree(pathified);
6460     Safefree(unixified);
6461     return NULL;
6462   }
6463   Safefree(pathified);
6464   if (buf) {
6465     Safefree(unixified);
6466     return buf;
6467   }
6468   else if (ts) {
6469     unixlen = strlen(unixified);
6470     Newx(cp,unixlen+1,char);
6471     memcpy(cp,unixified,unixlen);
6472     cp[unixlen] = '\0';
6473     Safefree(unixified);
6474     return cp;
6475   }
6476   else {
6477     strcpy(__tounixpath_retbuf,unixified);
6478     Safefree(unixified);
6479     return __tounixpath_retbuf;
6480   }
6481
6482 }  /* end of do_tounixpath() */
6483 /*}}}*/
6484 /* External entry points */
6485 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6486 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6487
6488 /*
6489  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6490  *
6491  *****************************************************************************
6492  *                                                                           *
6493  *  Copyright (C) 1989-1994 by                                               *
6494  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6495  *                                                                           *
6496  *  Permission is hereby  granted for the reproduction of this software,     *
6497  *  on condition that this copyright notice is included in the reproduction, *
6498  *  and that such reproduction is not for purposes of profit or material     *
6499  *  gain.                                                                    *
6500  *                                                                           *
6501  *  27-Aug-1994 Modified for inclusion in perl5                              *
6502  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6503  *****************************************************************************
6504  */
6505
6506 /*
6507  * getredirection() is intended to aid in porting C programs
6508  * to VMS (Vax-11 C).  The native VMS environment does not support
6509  * '>' and '<' I/O redirection, or command line wild card expansion,
6510  * or a command line pipe mechanism using the '|' AND background
6511  * command execution '&'.  All of these capabilities are provided to any
6512  * C program which calls this procedure as the first thing in the
6513  * main program.
6514  * The piping mechanism will probably work with almost any 'filter' type
6515  * of program.  With suitable modification, it may useful for other
6516  * portability problems as well.
6517  *
6518  * Author:  Mark Pizzolato      mark@infocomm.com
6519  */
6520 struct list_item
6521     {
6522     struct list_item *next;
6523     char *value;
6524     };
6525
6526 static void add_item(struct list_item **head,
6527                      struct list_item **tail,
6528                      char *value,
6529                      int *count);
6530
6531 static void mp_expand_wild_cards(pTHX_ char *item,
6532                                 struct list_item **head,
6533                                 struct list_item **tail,
6534                                 int *count);
6535
6536 static int background_process(pTHX_ int argc, char **argv);
6537
6538 static void pipe_and_fork(pTHX_ char **cmargv);
6539
6540 /*{{{ void getredirection(int *ac, char ***av)*/
6541 static void
6542 mp_getredirection(pTHX_ int *ac, char ***av)
6543 /*
6544  * Process vms redirection arg's.  Exit if any error is seen.
6545  * If getredirection() processes an argument, it is erased
6546  * from the vector.  getredirection() returns a new argc and argv value.
6547  * In the event that a background command is requested (by a trailing "&"),
6548  * this routine creates a background subprocess, and simply exits the program.
6549  *
6550  * Warning: do not try to simplify the code for vms.  The code
6551  * presupposes that getredirection() is called before any data is
6552  * read from stdin or written to stdout.
6553  *
6554  * Normal usage is as follows:
6555  *
6556  *      main(argc, argv)
6557  *      int             argc;
6558  *      char            *argv[];
6559  *      {
6560  *              getredirection(&argc, &argv);
6561  *      }
6562  */
6563 {
6564     int                 argc = *ac;     /* Argument Count         */
6565     char                **argv = *av;   /* Argument Vector        */
6566     char                *ap;            /* Argument pointer       */
6567     int                 j;              /* argv[] index           */
6568     int                 item_count = 0; /* Count of Items in List */
6569     struct list_item    *list_head = 0; /* First Item in List       */
6570     struct list_item    *list_tail;     /* Last Item in List        */
6571     char                *in = NULL;     /* Input File Name          */
6572     char                *out = NULL;    /* Output File Name         */
6573     char                *outmode = "w"; /* Mode to Open Output File */
6574     char                *err = NULL;    /* Error File Name          */
6575     char                *errmode = "w"; /* Mode to Open Error File  */
6576     int                 cmargc = 0;     /* Piped Command Arg Count  */
6577     char                **cmargv = NULL;/* Piped Command Arg Vector */
6578
6579     /*
6580      * First handle the case where the last thing on the line ends with
6581      * a '&'.  This indicates the desire for the command to be run in a
6582      * subprocess, so we satisfy that desire.
6583      */
6584     ap = argv[argc-1];
6585     if (0 == strcmp("&", ap))
6586        exit(background_process(aTHX_ --argc, argv));
6587     if (*ap && '&' == ap[strlen(ap)-1])
6588         {
6589         ap[strlen(ap)-1] = '\0';
6590        exit(background_process(aTHX_ argc, argv));
6591         }
6592     /*
6593      * Now we handle the general redirection cases that involve '>', '>>',
6594      * '<', and pipes '|'.
6595      */
6596     for (j = 0; j < argc; ++j)
6597         {
6598         if (0 == strcmp("<", argv[j]))
6599             {
6600             if (j+1 >= argc)
6601                 {
6602                 fprintf(stderr,"No input file after < on command line");
6603                 exit(LIB$_WRONUMARG);
6604                 }
6605             in = argv[++j];
6606             continue;
6607             }
6608         if ('<' == *(ap = argv[j]))
6609             {
6610             in = 1 + ap;
6611             continue;
6612             }
6613         if (0 == strcmp(">", ap))
6614             {
6615             if (j+1 >= argc)
6616                 {
6617                 fprintf(stderr,"No output file after > on command line");
6618                 exit(LIB$_WRONUMARG);
6619                 }
6620             out = argv[++j];
6621             continue;
6622             }
6623         if ('>' == *ap)
6624             {
6625             if ('>' == ap[1])
6626                 {
6627                 outmode = "a";
6628                 if ('\0' == ap[2])
6629                     out = argv[++j];
6630                 else
6631                     out = 2 + ap;
6632                 }
6633             else
6634                 out = 1 + ap;
6635             if (j >= argc)
6636                 {
6637                 fprintf(stderr,"No output file after > or >> on command line");
6638                 exit(LIB$_WRONUMARG);
6639                 }
6640             continue;
6641             }
6642         if (('2' == *ap) && ('>' == ap[1]))
6643             {
6644             if ('>' == ap[2])
6645                 {
6646                 errmode = "a";
6647                 if ('\0' == ap[3])
6648                     err = argv[++j];
6649                 else
6650                     err = 3 + ap;
6651                 }
6652             else
6653                 if ('\0' == ap[2])
6654                     err = argv[++j];
6655                 else
6656                     err = 2 + ap;
6657             if (j >= argc)
6658                 {
6659                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6660                 exit(LIB$_WRONUMARG);
6661                 }
6662             continue;
6663             }
6664         if (0 == strcmp("|", argv[j]))
6665             {
6666             if (j+1 >= argc)
6667                 {
6668                 fprintf(stderr,"No command into which to pipe on command line");
6669                 exit(LIB$_WRONUMARG);
6670                 }
6671             cmargc = argc-(j+1);
6672             cmargv = &argv[j+1];
6673             argc = j;
6674             continue;
6675             }
6676         if ('|' == *(ap = argv[j]))
6677             {
6678             ++argv[j];
6679             cmargc = argc-j;
6680             cmargv = &argv[j];
6681             argc = j;
6682             continue;
6683             }
6684         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6685         }
6686     /*
6687      * Allocate and fill in the new argument vector, Some Unix's terminate
6688      * the list with an extra null pointer.
6689      */
6690     Newx(argv, item_count+1, char *);
6691     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6692     *av = argv;
6693     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6694         argv[j] = list_head->value;
6695     *ac = item_count;
6696     if (cmargv != NULL)
6697         {
6698         if (out != NULL)
6699             {
6700             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6701             exit(LIB$_INVARGORD);
6702             }
6703         pipe_and_fork(aTHX_ cmargv);
6704         }
6705
6706     /* Check for input from a pipe (mailbox) */
6707
6708     if (in == NULL && 1 == isapipe(0))
6709         {
6710         char mbxname[L_tmpnam];
6711         long int bufsize;
6712         long int dvi_item = DVI$_DEVBUFSIZ;
6713         $DESCRIPTOR(mbxnam, "");
6714         $DESCRIPTOR(mbxdevnam, "");
6715
6716         /* Input from a pipe, reopen it in binary mode to disable       */
6717         /* carriage control processing.                                 */
6718
6719         fgetname(stdin, mbxname);
6720         mbxnam.dsc$a_pointer = mbxname;
6721         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6722         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6723         mbxdevnam.dsc$a_pointer = mbxname;
6724         mbxdevnam.dsc$w_length = sizeof(mbxname);
6725         dvi_item = DVI$_DEVNAM;
6726         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6727         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6728         set_errno(0);
6729         set_vaxc_errno(1);
6730         freopen(mbxname, "rb", stdin);
6731         if (errno != 0)
6732             {
6733             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6734             exit(vaxc$errno);
6735             }
6736         }
6737     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6738         {
6739         fprintf(stderr,"Can't open input file %s as stdin",in);
6740         exit(vaxc$errno);
6741         }
6742     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6743         {
6744         fprintf(stderr,"Can't open output file %s as stdout",out);
6745         exit(vaxc$errno);
6746         }
6747         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6748
6749     if (err != NULL) {
6750         if (strcmp(err,"&1") == 0) {
6751             dup2(fileno(stdout), fileno(stderr));
6752             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6753         } else {
6754         FILE *tmperr;
6755         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6756             {
6757             fprintf(stderr,"Can't open error file %s as stderr",err);
6758             exit(vaxc$errno);
6759             }
6760             fclose(tmperr);
6761            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6762                 {
6763                 exit(vaxc$errno);
6764                 }
6765             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6766         }
6767         }
6768 #ifdef ARGPROC_DEBUG
6769     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6770     for (j = 0; j < *ac;  ++j)
6771         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6772 #endif
6773    /* Clear errors we may have hit expanding wildcards, so they don't
6774       show up in Perl's $! later */
6775    set_errno(0); set_vaxc_errno(1);
6776 }  /* end of getredirection() */
6777 /*}}}*/
6778
6779 static void add_item(struct list_item **head,
6780                      struct list_item **tail,
6781                      char *value,
6782                      int *count)
6783 {
6784     if (*head == 0)
6785         {
6786         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6787         *tail = *head;
6788         }
6789     else {
6790         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6791         *tail = (*tail)->next;
6792         }
6793     (*tail)->value = value;
6794     ++(*count);
6795 }
6796
6797 static void mp_expand_wild_cards(pTHX_ char *item,
6798                               struct list_item **head,
6799                               struct list_item **tail,
6800                               int *count)
6801 {
6802 int expcount = 0;
6803 unsigned long int context = 0;
6804 int isunix = 0;
6805 int item_len = 0;
6806 char *had_version;
6807 char *had_device;
6808 int had_directory;
6809 char *devdir,*cp;
6810 char *vmsspec;
6811 $DESCRIPTOR(filespec, "");
6812 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6813 $DESCRIPTOR(resultspec, "");
6814 unsigned long int lff_flags = 0;
6815 int sts;
6816
6817 #ifdef VMS_LONGNAME_SUPPORT
6818     lff_flags = LIB$M_FIL_LONG_NAMES;
6819 #endif
6820
6821     for (cp = item; *cp; cp++) {
6822         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6823         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6824     }
6825     if (!*cp || isspace(*cp))
6826         {
6827         add_item(head, tail, item, count);
6828         return;
6829         }
6830     else
6831         {
6832      /* "double quoted" wild card expressions pass as is */
6833      /* From DCL that means using e.g.:                  */
6834      /* perl program """perl.*"""                        */
6835      item_len = strlen(item);
6836      if ( '"' == *item && '"' == item[item_len-1] )
6837        {
6838        item++;
6839        item[item_len-2] = '\0';
6840        add_item(head, tail, item, count);
6841        return;
6842        }
6843      }
6844     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6845     resultspec.dsc$b_class = DSC$K_CLASS_D;
6846     resultspec.dsc$a_pointer = NULL;
6847     Newx(vmsspec, VMS_MAXRSS, char);
6848     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6849       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6850     if (!isunix || !filespec.dsc$a_pointer)
6851       filespec.dsc$a_pointer = item;
6852     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6853     /*
6854      * Only return version specs, if the caller specified a version
6855      */
6856     had_version = strchr(item, ';');
6857     /*
6858      * Only return device and directory specs, if the caller specifed either.
6859      */
6860     had_device = strchr(item, ':');
6861     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6862
6863     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6864                                  (&filespec, &resultspec, &context,
6865                                   &defaultspec, 0, 0, &lff_flags)))
6866         {
6867         char *string;
6868         char *c;
6869
6870         Newx(string,resultspec.dsc$w_length+1,char);
6871         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6872         string[resultspec.dsc$w_length] = '\0';
6873         if (NULL == had_version)
6874             *(strrchr(string, ';')) = '\0';
6875         if ((!had_directory) && (had_device == NULL))
6876             {
6877             if (NULL == (devdir = strrchr(string, ']')))
6878                 devdir = strrchr(string, '>');
6879             strcpy(string, devdir + 1);
6880             }
6881         /*
6882          * Be consistent with what the C RTL has already done to the rest of
6883          * the argv items and lowercase all of these names.
6884          */
6885         if (!decc_efs_case_preserve) {
6886             for (c = string; *c; ++c)
6887             if (isupper(*c))
6888                 *c = tolower(*c);
6889         }
6890         if (isunix) trim_unixpath(string,item,1);
6891         add_item(head, tail, string, count);
6892         ++expcount;
6893     }
6894     Safefree(vmsspec);
6895     if (sts != RMS$_NMF)
6896         {
6897         set_vaxc_errno(sts);
6898         switch (sts)
6899             {
6900             case RMS$_FNF: case RMS$_DNF:
6901                 set_errno(ENOENT); break;
6902             case RMS$_DIR:
6903                 set_errno(ENOTDIR); break;
6904             case RMS$_DEV:
6905                 set_errno(ENODEV); break;
6906             case RMS$_FNM: case RMS$_SYN:
6907                 set_errno(EINVAL); break;
6908             case RMS$_PRV:
6909                 set_errno(EACCES); break;
6910             default:
6911                 _ckvmssts_noperl(sts);
6912             }
6913         }
6914     if (expcount == 0)
6915         add_item(head, tail, item, count);
6916     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6917     _ckvmssts_noperl(lib$find_file_end(&context));
6918 }
6919
6920 static int child_st[2];/* Event Flag set when child process completes   */
6921
6922 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6923
6924 static unsigned long int exit_handler(int *status)
6925 {
6926 short iosb[4];
6927
6928     if (0 == child_st[0])
6929         {
6930 #ifdef ARGPROC_DEBUG
6931         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6932 #endif
6933         fflush(stdout);     /* Have to flush pipe for binary data to    */
6934                             /* terminate properly -- <tp@mccall.com>    */
6935         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6936         sys$dassgn(child_chan);
6937         fclose(stdout);
6938         sys$synch(0, child_st);
6939         }
6940     return(1);
6941 }
6942
6943 static void sig_child(int chan)
6944 {
6945 #ifdef ARGPROC_DEBUG
6946     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6947 #endif
6948     if (child_st[0] == 0)
6949         child_st[0] = 1;
6950 }
6951
6952 static struct exit_control_block exit_block =
6953     {
6954     0,
6955     exit_handler,
6956     1,
6957     &exit_block.exit_status,
6958     0
6959     };
6960
6961 static void
6962 pipe_and_fork(pTHX_ char **cmargv)
6963 {
6964     PerlIO *fp;
6965     struct dsc$descriptor_s *vmscmd;
6966     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6967     int sts, j, l, ismcr, quote, tquote = 0;
6968
6969     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6970     vms_execfree(vmscmd);
6971
6972     j = l = 0;
6973     p = subcmd;
6974     q = cmargv[0];
6975     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6976               && toupper(*(q+2)) == 'R' && !*(q+3);
6977
6978     while (q && l < MAX_DCL_LINE_LENGTH) {
6979         if (!*q) {
6980             if (j > 0 && quote) {
6981                 *p++ = '"';
6982                 l++;
6983             }
6984             q = cmargv[++j];
6985             if (q) {
6986                 if (ismcr && j > 1) quote = 1;
6987                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6988                 *p++ = ' ';
6989                 l++;
6990                 if (quote || tquote) {
6991                     *p++ = '"';
6992                     l++;
6993                 }
6994         }
6995         } else {
6996             if ((quote||tquote) && *q == '"') {
6997                 *p++ = '"';
6998                 l++;
6999         }
7000             *p++ = *q++;
7001             l++;
7002         }
7003     }
7004     *p = '\0';
7005
7006     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7007     if (fp == Nullfp) {
7008         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7009         }
7010 }
7011
7012 static int background_process(pTHX_ int argc, char **argv)
7013 {
7014 char command[MAX_DCL_SYMBOL + 1] = "$";
7015 $DESCRIPTOR(value, "");
7016 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7017 static $DESCRIPTOR(null, "NLA0:");
7018 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7019 char pidstring[80];
7020 $DESCRIPTOR(pidstr, "");
7021 int pid;
7022 unsigned long int flags = 17, one = 1, retsts;
7023 int len;
7024
7025     strcat(command, argv[0]);
7026     len = strlen(command);
7027     while (--argc && (len < MAX_DCL_SYMBOL))
7028         {
7029         strcat(command, " \"");
7030         strcat(command, *(++argv));
7031         strcat(command, "\"");
7032         len = strlen(command);
7033         }
7034     value.dsc$a_pointer = command;
7035     value.dsc$w_length = strlen(value.dsc$a_pointer);
7036     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7037     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7038     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7039         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7040     }
7041     else {
7042         _ckvmssts_noperl(retsts);
7043     }
7044 #ifdef ARGPROC_DEBUG
7045     PerlIO_printf(Perl_debug_log, "%s\n", command);
7046 #endif
7047     sprintf(pidstring, "%08X", pid);
7048     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7049     pidstr.dsc$a_pointer = pidstring;
7050     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7051     lib$set_symbol(&pidsymbol, &pidstr);
7052     return(SS$_NORMAL);
7053 }
7054 /*}}}*/
7055 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7056
7057
7058 /* OS-specific initialization at image activation (not thread startup) */
7059 /* Older VAXC header files lack these constants */
7060 #ifndef JPI$_RIGHTS_SIZE
7061 #  define JPI$_RIGHTS_SIZE 817
7062 #endif
7063 #ifndef KGB$M_SUBSYSTEM
7064 #  define KGB$M_SUBSYSTEM 0x8
7065 #endif
7066
7067 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7068
7069 /*{{{void vms_image_init(int *, char ***)*/
7070 void
7071 vms_image_init(int *argcp, char ***argvp)
7072 {
7073   char eqv[LNM$C_NAMLENGTH+1] = "";
7074   unsigned int len, tabct = 8, tabidx = 0;
7075   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7076   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7077   unsigned short int dummy, rlen;
7078   struct dsc$descriptor_s **tabvec;
7079 #if defined(PERL_IMPLICIT_CONTEXT)
7080   pTHX = NULL;
7081 #endif
7082   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7083                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7084                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7085                                  {          0,                0,    0,      0} };
7086
7087 #ifdef KILL_BY_SIGPRC
7088     Perl_csighandler_init();
7089 #endif
7090
7091   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7092   _ckvmssts_noperl(iosb[0]);
7093   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7094     if (iprv[i]) {           /* Running image installed with privs? */
7095       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7096       will_taint = TRUE;
7097       break;
7098     }
7099   }
7100   /* Rights identifiers might trigger tainting as well. */
7101   if (!will_taint && (rlen || rsz)) {
7102     while (rlen < rsz) {
7103       /* We didn't get all the identifiers on the first pass.  Allocate a
7104        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7105        * were needed to hold all identifiers at time of last call; we'll
7106        * allocate that many unsigned long ints), and go back and get 'em.
7107        * If it gave us less than it wanted to despite ample buffer space,
7108        * something's broken.  Is your system missing a system identifier?
7109        */
7110       if (rsz <= jpilist[1].buflen) {
7111          /* Perl_croak accvios when used this early in startup. */
7112          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7113                          rsz, (unsigned long) jpilist[1].buflen,
7114                          "Check your rights database for corruption.\n");
7115          exit(SS$_ABORT);
7116       }
7117       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7118       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7119       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7120       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7121       _ckvmssts_noperl(iosb[0]);
7122     }
7123     mask = jpilist[1].bufadr;
7124     /* Check attribute flags for each identifier (2nd longword); protected
7125      * subsystem identifiers trigger tainting.
7126      */
7127     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7128       if (mask[i] & KGB$M_SUBSYSTEM) {
7129         will_taint = TRUE;
7130         break;
7131       }
7132     }
7133     if (mask != rlst) Safefree(mask);
7134   }
7135
7136   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7137    * logical, some versions of the CRTL will add a phanthom /000000/
7138    * directory.  This needs to be removed.
7139    */
7140   if (decc_filename_unix_report) {
7141   char * zeros;
7142   int ulen;
7143     ulen = strlen(argvp[0][0]);
7144     if (ulen > 7) {
7145       zeros = strstr(argvp[0][0], "/000000/");
7146       if (zeros != NULL) {
7147         int mlen;
7148         mlen = ulen - (zeros - argvp[0][0]) - 7;
7149         memmove(zeros, &zeros[7], mlen);
7150         ulen = ulen - 7;
7151         argvp[0][0][ulen] = '\0';
7152       }
7153     }
7154     /* It also may have a trailing dot that needs to be removed otherwise
7155      * it will be converted to VMS mode incorrectly.
7156      */
7157     ulen--;
7158     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7159       argvp[0][0][ulen] = '\0';
7160   }
7161
7162   /* We need to use this hack to tell Perl it should run with tainting,
7163    * since its tainting flag may be part of the PL_curinterp struct, which
7164    * hasn't been allocated when vms_image_init() is called.
7165    */
7166   if (will_taint) {
7167     char **newargv, **oldargv;
7168     oldargv = *argvp;
7169     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7170     newargv[0] = oldargv[0];
7171     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7172     strcpy(newargv[1], "-T");
7173     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7174     (*argcp)++;
7175     newargv[*argcp] = NULL;
7176     /* We orphan the old argv, since we don't know where it's come from,
7177      * so we don't know how to free it.
7178      */
7179     *argvp = newargv;
7180   }
7181   else {  /* Did user explicitly request tainting? */
7182     int i;
7183     char *cp, **av = *argvp;
7184     for (i = 1; i < *argcp; i++) {
7185       if (*av[i] != '-') break;
7186       for (cp = av[i]+1; *cp; cp++) {
7187         if (*cp == 'T') { will_taint = 1; break; }
7188         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7189                   strchr("DFIiMmx",*cp)) break;
7190       }
7191       if (will_taint) break;
7192     }
7193   }
7194
7195   for (tabidx = 0;
7196        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7197        tabidx++) {
7198     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7199     else if (tabidx >= tabct) {
7200       tabct += 8;
7201       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7202     }
7203     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7204     tabvec[tabidx]->dsc$w_length  = 0;
7205     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7206     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7207     tabvec[tabidx]->dsc$a_pointer = NULL;
7208     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7209   }
7210   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7211
7212   getredirection(argcp,argvp);
7213 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7214   {
7215 # include <reentrancy.h>
7216   decc$set_reentrancy(C$C_MULTITHREAD);
7217   }
7218 #endif
7219   return;
7220 }
7221 /*}}}*/
7222
7223
7224 /* trim_unixpath()
7225  * Trim Unix-style prefix off filespec, so it looks like what a shell
7226  * glob expansion would return (i.e. from specified prefix on, not
7227  * full path).  Note that returned filespec is Unix-style, regardless
7228  * of whether input filespec was VMS-style or Unix-style.
7229  *
7230  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7231  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7232  * vector of options; at present, only bit 0 is used, and if set tells
7233  * trim unixpath to try the current default directory as a prefix when
7234  * presented with a possibly ambiguous ... wildcard.
7235  *
7236  * Returns !=0 on success, with trimmed filespec replacing contents of
7237  * fspec, and 0 on failure, with contents of fpsec unchanged.
7238  */
7239 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7240 int
7241 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7242 {
7243   char *unixified, *unixwild,
7244        *template, *base, *end, *cp1, *cp2;
7245   register int tmplen, reslen = 0, dirs = 0;
7246
7247   Newx(unixwild, VMS_MAXRSS, char);
7248   if (!wildspec || !fspec) return 0;
7249   template = unixwild;
7250   if (strpbrk(wildspec,"]>:") != NULL) {
7251     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7252         Safefree(unixwild);
7253         return 0;
7254     }
7255   }
7256   else {
7257     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7258     unixwild[VMS_MAXRSS-1] = 0;
7259   }
7260   Newx(unixified, VMS_MAXRSS, char);
7261   if (strpbrk(fspec,"]>:") != NULL) {
7262     if (do_tounixspec(fspec,unixified,0) == NULL) {
7263         Safefree(unixwild);
7264         Safefree(unixified);
7265         return 0;
7266     }
7267     else base = unixified;
7268     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7269      * check to see that final result fits into (isn't longer than) fspec */
7270     reslen = strlen(fspec);
7271   }
7272   else base = fspec;
7273
7274   /* No prefix or absolute path on wildcard, so nothing to remove */
7275   if (!*template || *template == '/') {
7276     Safefree(unixwild);
7277     if (base == fspec) {
7278         Safefree(unixified);
7279         return 1;
7280     }
7281     tmplen = strlen(unixified);
7282     if (tmplen > reslen) {
7283         Safefree(unixified);
7284         return 0;  /* not enough space */
7285     }
7286     /* Copy unixified resultant, including trailing NUL */
7287     memmove(fspec,unixified,tmplen+1);
7288     Safefree(unixified);
7289     return 1;
7290   }
7291
7292   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7293   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7294     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7295     for (cp1 = end ;cp1 >= base; cp1--)
7296       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7297         { cp1++; break; }
7298     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7299     Safefree(unixified);
7300     Safefree(unixwild);
7301     return 1;
7302   }
7303   else {
7304     char *tpl, *lcres;
7305     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7306     int ells = 1, totells, segdirs, match;
7307     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7308                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7309
7310     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7311     totells = ells;
7312     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7313     Newx(tpl, VMS_MAXRSS, char);
7314     if (ellipsis == template && opts & 1) {
7315       /* Template begins with an ellipsis.  Since we can't tell how many
7316        * directory names at the front of the resultant to keep for an
7317        * arbitrary starting point, we arbitrarily choose the current
7318        * default directory as a starting point.  If it's there as a prefix,
7319        * clip it off.  If not, fall through and act as if the leading
7320        * ellipsis weren't there (i.e. return shortest possible path that
7321        * could match template).
7322        */
7323       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7324           Safefree(tpl);
7325           Safefree(unixified);
7326           Safefree(unixwild);
7327           return 0;
7328       }
7329       if (!decc_efs_case_preserve) {
7330         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7331           if (_tolower(*cp1) != _tolower(*cp2)) break;
7332       }
7333       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7334       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7335       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7336         memmove(fspec,cp2+1,end - cp2);
7337         Safefree(unixified);
7338         Safefree(unixwild);
7339         Safefree(tpl);
7340         return 1;
7341       }
7342     }
7343     /* First off, back up over constant elements at end of path */
7344     if (dirs) {
7345       for (front = end ; front >= base; front--)
7346          if (*front == '/' && !dirs--) { front++; break; }
7347     }
7348     Newx(lcres, VMS_MAXRSS, char);
7349     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7350          cp1++,cp2++) {
7351             if (!decc_efs_case_preserve) {
7352                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7353             }
7354             else {
7355                 *cp2 = *cp1;
7356             }
7357     }
7358     if (cp1 != '\0') {
7359         Safefree(unixified);
7360         Safefree(unixwild);
7361         Safefree(lcres);
7362         Safefree(tpl);
7363         return 0;  /* Path too long. */
7364     }
7365     lcend = cp2;
7366     *cp2 = '\0';  /* Pick up with memcpy later */
7367     lcfront = lcres + (front - base);
7368     /* Now skip over each ellipsis and try to match the path in front of it. */
7369     while (ells--) {
7370       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7371         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7372             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7373       if (cp1 < template) break; /* template started with an ellipsis */
7374       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7375         ellipsis = cp1; continue;
7376       }
7377       wilddsc.dsc$a_pointer = tpl;
7378       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7379       nextell = cp1;
7380       for (segdirs = 0, cp2 = tpl;
7381            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7382            cp1++, cp2++) {
7383          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7384          else {
7385             if (!decc_efs_case_preserve) {
7386               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7387             }
7388             else {
7389               *cp2 = *cp1;  /* else preserve case for match */
7390             }
7391          }
7392          if (*cp2 == '/') segdirs++;
7393       }
7394       if (cp1 != ellipsis - 1) {
7395           Safefree(unixified);
7396           Safefree(unixwild);
7397           Safefree(lcres);
7398           Safefree(tpl);
7399           return 0; /* Path too long */
7400       }
7401       /* Back up at least as many dirs as in template before matching */
7402       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7403         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7404       for (match = 0; cp1 > lcres;) {
7405         resdsc.dsc$a_pointer = cp1;
7406         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7407           match++;
7408           if (match == 1) lcfront = cp1;
7409         }
7410         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7411       }
7412       if (!match) {
7413         Safefree(unixified);
7414         Safefree(unixwild);
7415         Safefree(lcres);
7416         Safefree(tpl);
7417         return 0;  /* Can't find prefix ??? */
7418       }
7419       if (match > 1 && opts & 1) {
7420         /* This ... wildcard could cover more than one set of dirs (i.e.
7421          * a set of similar dir names is repeated).  If the template
7422          * contains more than 1 ..., upstream elements could resolve the
7423          * ambiguity, but it's not worth a full backtracking setup here.
7424          * As a quick heuristic, clip off the current default directory
7425          * if it's present to find the trimmed spec, else use the
7426          * shortest string that this ... could cover.
7427          */
7428         char def[NAM$C_MAXRSS+1], *st;
7429
7430         if (getcwd(def, sizeof def,0) == NULL) {
7431             Safefree(unixified);
7432             Safefree(unixwild);
7433             Safefree(lcres);
7434             Safefree(tpl);
7435             return 0;
7436         }
7437         if (!decc_efs_case_preserve) {
7438           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7439             if (_tolower(*cp1) != _tolower(*cp2)) break;
7440         }
7441         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7442         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7443         if (*cp1 == '\0' && *cp2 == '/') {
7444           memmove(fspec,cp2+1,end - cp2);
7445           Safefree(lcres);
7446           Safefree(unixified);
7447           Safefree(unixwild);
7448           Safefree(tpl);
7449           return 1;
7450         }
7451         /* Nope -- stick with lcfront from above and keep going. */
7452       }
7453     }
7454     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7455     Safefree(unixified);
7456     Safefree(unixwild);
7457     Safefree(lcres);
7458     Safefree(tpl);
7459     return 1;
7460     ellipsis = nextell;
7461   }
7462
7463 }  /* end of trim_unixpath() */
7464 /*}}}*/
7465
7466
7467 /*
7468  *  VMS readdir() routines.
7469  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7470  *
7471  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7472  *  Minor modifications to original routines.
7473  */
7474
7475 /* readdir may have been redefined by reentr.h, so make sure we get
7476  * the local version for what we do here.
7477  */
7478 #ifdef readdir
7479 # undef readdir
7480 #endif
7481 #if !defined(PERL_IMPLICIT_CONTEXT)
7482 # define readdir Perl_readdir
7483 #else
7484 # define readdir(a) Perl_readdir(aTHX_ a)
7485 #endif
7486
7487     /* Number of elements in vms_versions array */
7488 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7489
7490 /*
7491  *  Open a directory, return a handle for later use.
7492  */
7493 /*{{{ DIR *opendir(char*name) */
7494 MY_DIR *
7495 Perl_opendir(pTHX_ const char *name)
7496 {
7497     MY_DIR *dd;
7498     char dir[NAM$C_MAXRSS+1];
7499     Stat_t sb;
7500
7501     if (do_tovmspath(name,dir,0) == NULL) {
7502       return NULL;
7503     }
7504     /* Check access before stat; otherwise stat does not
7505      * accurately report whether it's a directory.
7506      */
7507     if (!cando_by_name(S_IRUSR,0,dir)) {
7508       /* cando_by_name has already set errno */
7509       return NULL;
7510     }
7511     if (flex_stat(dir,&sb) == -1) return NULL;
7512     if (!S_ISDIR(sb.st_mode)) {
7513       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7514       return NULL;
7515     }
7516     /* Get memory for the handle, and the pattern. */
7517     Newx(dd,1,MY_DIR);
7518     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7519
7520     /* Fill in the fields; mainly playing with the descriptor. */
7521     sprintf(dd->pattern, "%s*.*",dir);
7522     dd->context = 0;
7523     dd->count = 0;
7524     dd->vms_wantversions = 0;
7525     dd->pat.dsc$a_pointer = dd->pattern;
7526     dd->pat.dsc$w_length = strlen(dd->pattern);
7527     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7528     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7529 #if defined(USE_ITHREADS)
7530     Newx(dd->mutex,1,perl_mutex);
7531     MUTEX_INIT( (perl_mutex *) dd->mutex );
7532 #else
7533     dd->mutex = NULL;
7534 #endif
7535
7536     return dd;
7537 }  /* end of opendir() */
7538 /*}}}*/
7539
7540 /*
7541  *  Set the flag to indicate we want versions or not.
7542  */
7543 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7544 void
7545 vmsreaddirversions(MY_DIR *dd, int flag)
7546 {
7547     dd->vms_wantversions = flag;
7548 }
7549 /*}}}*/
7550
7551 /*
7552  *  Free up an opened directory.
7553  */
7554 /*{{{ void closedir(DIR *dd)*/
7555 void
7556 Perl_closedir(MY_DIR *dd)
7557 {
7558     int sts;
7559
7560     sts = lib$find_file_end(&dd->context);
7561     Safefree(dd->pattern);
7562 #if defined(USE_ITHREADS)
7563     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7564     Safefree(dd->mutex);
7565 #endif
7566     Safefree(dd);
7567 }
7568 /*}}}*/
7569
7570 /*
7571  *  Collect all the version numbers for the current file.
7572  */
7573 static void
7574 collectversions(pTHX_ MY_DIR *dd)
7575 {
7576     struct dsc$descriptor_s     pat;
7577     struct dsc$descriptor_s     res;
7578     struct my_dirent *e;
7579     char *p, *text, buff[sizeof dd->entry.d_name];
7580     int i;
7581     unsigned long context, tmpsts;
7582
7583     /* Convenient shorthand. */
7584     e = &dd->entry;
7585
7586     /* Add the version wildcard, ignoring the "*.*" put on before */
7587     i = strlen(dd->pattern);
7588     Newx(text,i + e->d_namlen + 3,char);
7589     strcpy(text, dd->pattern);
7590     sprintf(&text[i - 3], "%s;*", e->d_name);
7591
7592     /* Set up the pattern descriptor. */
7593     pat.dsc$a_pointer = text;
7594     pat.dsc$w_length = i + e->d_namlen - 1;
7595     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7596     pat.dsc$b_class = DSC$K_CLASS_S;
7597
7598     /* Set up result descriptor. */
7599     res.dsc$a_pointer = buff;
7600     res.dsc$w_length = sizeof buff - 2;
7601     res.dsc$b_dtype = DSC$K_DTYPE_T;
7602     res.dsc$b_class = DSC$K_CLASS_S;
7603
7604     /* Read files, collecting versions. */
7605     for (context = 0, e->vms_verscount = 0;
7606          e->vms_verscount < VERSIZE(e);
7607          e->vms_verscount++) {
7608         tmpsts = lib$find_file(&pat, &res, &context);
7609         if (tmpsts == RMS$_NMF || context == 0) break;
7610         _ckvmssts(tmpsts);
7611         buff[sizeof buff - 1] = '\0';
7612         if ((p = strchr(buff, ';')))
7613             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7614         else
7615             e->vms_versions[e->vms_verscount] = -1;
7616     }
7617
7618     _ckvmssts(lib$find_file_end(&context));
7619     Safefree(text);
7620
7621 }  /* end of collectversions() */
7622
7623 /*
7624  *  Read the next entry from the directory.
7625  */
7626 /*{{{ struct dirent *readdir(DIR *dd)*/
7627 struct my_dirent *
7628 Perl_readdir(pTHX_ MY_DIR *dd)
7629 {
7630     struct dsc$descriptor_s     res;
7631     char *p, buff[sizeof dd->entry.d_name];
7632     unsigned long int tmpsts;
7633
7634     /* Set up result descriptor, and get next file. */
7635     res.dsc$a_pointer = buff;
7636     res.dsc$w_length = sizeof buff - 2;
7637     res.dsc$b_dtype = DSC$K_DTYPE_T;
7638     res.dsc$b_class = DSC$K_CLASS_S;
7639     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7640     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7641     if (!(tmpsts & 1)) {
7642       set_vaxc_errno(tmpsts);
7643       switch (tmpsts) {
7644         case RMS$_PRV:
7645           set_errno(EACCES); break;
7646         case RMS$_DEV:
7647           set_errno(ENODEV); break;
7648         case RMS$_DIR:
7649           set_errno(ENOTDIR); break;
7650         case RMS$_FNF: case RMS$_DNF:
7651           set_errno(ENOENT); break;
7652         default:
7653           set_errno(EVMSERR);
7654       }
7655       return NULL;
7656     }
7657     dd->count++;
7658     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7659     if (!decc_efs_case_preserve) {
7660       buff[sizeof buff - 1] = '\0';
7661       for (p = buff; *p; p++) *p = _tolower(*p);
7662       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7663       *p = '\0';
7664     }
7665     else {
7666       /* we don't want to force to lowercase, just null terminate */
7667       buff[res.dsc$w_length] = '\0';
7668     }
7669     for (p = buff; *p; p++) *p = _tolower(*p);
7670     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7671     *p = '\0';
7672
7673     /* Skip any directory component and just copy the name. */
7674     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7675     else strcpy(dd->entry.d_name, buff);
7676
7677     /* Clobber the version. */
7678     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7679
7680     dd->entry.d_namlen = strlen(dd->entry.d_name);
7681     dd->entry.vms_verscount = 0;
7682     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7683     return &dd->entry;
7684
7685 }  /* end of readdir() */
7686 /*}}}*/
7687
7688 /*
7689  *  Read the next entry from the directory -- thread-safe version.
7690  */
7691 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7692 int
7693 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7694 {
7695     int retval;
7696
7697     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7698
7699     entry = readdir(dd);
7700     *result = entry;
7701     retval = ( *result == NULL ? errno : 0 );
7702
7703     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7704
7705     return retval;
7706
7707 }  /* end of readdir_r() */
7708 /*}}}*/
7709
7710 /*
7711  *  Return something that can be used in a seekdir later.
7712  */
7713 /*{{{ long telldir(DIR *dd)*/
7714 long
7715 Perl_telldir(MY_DIR *dd)
7716 {
7717     return dd->count;
7718 }
7719 /*}}}*/
7720
7721 /*
7722  *  Return to a spot where we used to be.  Brute force.
7723  */
7724 /*{{{ void seekdir(DIR *dd,long count)*/
7725 void
7726 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7727 {
7728     int vms_wantversions;
7729
7730     /* If we haven't done anything yet... */
7731     if (dd->count == 0)
7732         return;
7733
7734     /* Remember some state, and clear it. */
7735     vms_wantversions = dd->vms_wantversions;
7736     dd->vms_wantversions = 0;
7737     _ckvmssts(lib$find_file_end(&dd->context));
7738     dd->context = 0;
7739
7740     /* The increment is in readdir(). */
7741     for (dd->count = 0; dd->count < count; )
7742         readdir(dd);
7743
7744     dd->vms_wantversions = vms_wantversions;
7745
7746 }  /* end of seekdir() */
7747 /*}}}*/
7748
7749 /* VMS subprocess management
7750  *
7751  * my_vfork() - just a vfork(), after setting a flag to record that
7752  * the current script is trying a Unix-style fork/exec.
7753  *
7754  * vms_do_aexec() and vms_do_exec() are called in response to the
7755  * perl 'exec' function.  If this follows a vfork call, then they
7756  * call out the regular perl routines in doio.c which do an
7757  * execvp (for those who really want to try this under VMS).
7758  * Otherwise, they do exactly what the perl docs say exec should
7759  * do - terminate the current script and invoke a new command
7760  * (See below for notes on command syntax.)
7761  *
7762  * do_aspawn() and do_spawn() implement the VMS side of the perl
7763  * 'system' function.
7764  *
7765  * Note on command arguments to perl 'exec' and 'system': When handled
7766  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7767  * are concatenated to form a DCL command string.  If the first arg
7768  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7769  * the command string is handed off to DCL directly.  Otherwise,
7770  * the first token of the command is taken as the filespec of an image
7771  * to run.  The filespec is expanded using a default type of '.EXE' and
7772  * the process defaults for device, directory, etc., and if found, the resultant
7773  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7774  * the command string as parameters.  This is perhaps a bit complicated,
7775  * but I hope it will form a happy medium between what VMS folks expect
7776  * from lib$spawn and what Unix folks expect from exec.
7777  */
7778
7779 static int vfork_called;
7780
7781 /*{{{int my_vfork()*/
7782 int
7783 my_vfork()
7784 {
7785   vfork_called++;
7786   return vfork();
7787 }
7788 /*}}}*/
7789
7790
7791 static void
7792 vms_execfree(struct dsc$descriptor_s *vmscmd)
7793 {
7794   if (vmscmd) {
7795       if (vmscmd->dsc$a_pointer) {
7796           Safefree(vmscmd->dsc$a_pointer);
7797       }
7798       Safefree(vmscmd);
7799   }
7800 }
7801
7802 static char *
7803 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7804 {
7805   char *junk, *tmps = Nullch;
7806   register size_t cmdlen = 0;
7807   size_t rlen;
7808   register SV **idx;
7809   STRLEN n_a;
7810
7811   idx = mark;
7812   if (really) {
7813     tmps = SvPV(really,rlen);
7814     if (*tmps) {
7815       cmdlen += rlen + 1;
7816       idx++;
7817     }
7818   }
7819
7820   for (idx++; idx <= sp; idx++) {
7821     if (*idx) {
7822       junk = SvPVx(*idx,rlen);
7823       cmdlen += rlen ? rlen + 1 : 0;
7824     }
7825   }
7826   Newx(PL_Cmd,cmdlen+1,char);
7827
7828   if (tmps && *tmps) {
7829     strcpy(PL_Cmd,tmps);
7830     mark++;
7831   }
7832   else *PL_Cmd = '\0';
7833   while (++mark <= sp) {
7834     if (*mark) {
7835       char *s = SvPVx(*mark,n_a);
7836       if (!*s) continue;
7837       if (*PL_Cmd) strcat(PL_Cmd," ");
7838       strcat(PL_Cmd,s);
7839     }
7840   }
7841   return PL_Cmd;
7842
7843 }  /* end of setup_argstr() */
7844
7845
7846 static unsigned long int
7847 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7848                    struct dsc$descriptor_s **pvmscmd)
7849 {
7850   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7851   char image_name[NAM$C_MAXRSS+1];
7852   char image_argv[NAM$C_MAXRSS+1];
7853   $DESCRIPTOR(defdsc,".EXE");
7854   $DESCRIPTOR(defdsc2,".");
7855   $DESCRIPTOR(resdsc,resspec);
7856   struct dsc$descriptor_s *vmscmd;
7857   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7858   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7859   register char *s, *rest, *cp, *wordbreak;
7860   char * cmd;
7861   int cmdlen;
7862   register int isdcl;
7863
7864   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7865
7866   /* Make a copy for modification */
7867   cmdlen = strlen(incmd);
7868   Newx(cmd, cmdlen+1, char);
7869   strncpy(cmd, incmd, cmdlen);
7870   cmd[cmdlen] = 0;
7871   image_name[0] = 0;
7872   image_argv[0] = 0;
7873
7874   vmscmd->dsc$a_pointer = NULL;
7875   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7876   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7877   vmscmd->dsc$w_length = 0;
7878   if (pvmscmd) *pvmscmd = vmscmd;
7879
7880   if (suggest_quote) *suggest_quote = 0;
7881
7882   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7883     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7884     Safefree(cmd);
7885   }
7886
7887   s = cmd;
7888
7889   while (*s && isspace(*s)) s++;
7890
7891   if (*s == '@' || *s == '$') {
7892     vmsspec[0] = *s;  rest = s + 1;
7893     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7894   }
7895   else { cp = vmsspec; rest = s; }
7896   if (*rest == '.' || *rest == '/') {
7897     char *cp2;
7898     for (cp2 = resspec;
7899          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7900          rest++, cp2++) *cp2 = *rest;
7901     *cp2 = '\0';
7902     if (do_tovmsspec(resspec,cp,0)) {
7903       s = vmsspec;
7904       if (*rest) {
7905         for (cp2 = vmsspec + strlen(vmsspec);
7906              *rest && cp2 - vmsspec < sizeof vmsspec;
7907              rest++, cp2++) *cp2 = *rest;
7908         *cp2 = '\0';
7909       }
7910     }
7911   }
7912   /* Intuit whether verb (first word of cmd) is a DCL command:
7913    *   - if first nonspace char is '@', it's a DCL indirection
7914    * otherwise
7915    *   - if verb contains a filespec separator, it's not a DCL command
7916    *   - if it doesn't, caller tells us whether to default to a DCL
7917    *     command, or to a local image unless told it's DCL (by leading '$')
7918    */
7919   if (*s == '@') {
7920       isdcl = 1;
7921       if (suggest_quote) *suggest_quote = 1;
7922   } else {
7923     register char *filespec = strpbrk(s,":<[.;");
7924     rest = wordbreak = strpbrk(s," \"\t/");
7925     if (!wordbreak) wordbreak = s + strlen(s);
7926     if (*s == '$') check_img = 0;
7927     if (filespec && (filespec < wordbreak)) isdcl = 0;
7928     else isdcl = !check_img;
7929   }
7930
7931   if (!isdcl) {
7932     imgdsc.dsc$a_pointer = s;
7933     imgdsc.dsc$w_length = wordbreak - s;
7934     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7935     if (!(retsts&1)) {
7936         _ckvmssts(lib$find_file_end(&cxt));
7937         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7938       if (!(retsts & 1) && *s == '$') {
7939         _ckvmssts(lib$find_file_end(&cxt));
7940         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7941         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7942         if (!(retsts&1)) {
7943           _ckvmssts(lib$find_file_end(&cxt));
7944           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7945         }
7946       }
7947     }
7948     _ckvmssts(lib$find_file_end(&cxt));
7949
7950     if (retsts & 1) {
7951       FILE *fp;
7952       s = resspec;
7953       while (*s && !isspace(*s)) s++;
7954       *s = '\0';
7955
7956       /* check that it's really not DCL with no file extension */
7957       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7958       if (fp) {
7959         char b[256] = {0,0,0,0};
7960         read(fileno(fp), b, 256);
7961         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7962         if (isdcl) {
7963           int shebang_len;
7964
7965           /* Check for script */
7966           shebang_len = 0;
7967           if ((b[0] == '#') && (b[1] == '!'))
7968              shebang_len = 2;
7969 #ifdef ALTERNATE_SHEBANG
7970           else {
7971             shebang_len = strlen(ALTERNATE_SHEBANG);
7972             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7973               char * perlstr;
7974                 perlstr = strstr("perl",b);
7975                 if (perlstr == NULL)
7976                   shebang_len = 0;
7977             }
7978             else
7979               shebang_len = 0;
7980           }
7981 #endif
7982
7983           if (shebang_len > 0) {
7984           int i;
7985           int j;
7986           char tmpspec[NAM$C_MAXRSS + 1];
7987
7988             i = shebang_len;
7989              /* Image is following after white space */
7990             /*--------------------------------------*/
7991             while (isprint(b[i]) && isspace(b[i]))
7992                 i++;
7993
7994             j = 0;
7995             while (isprint(b[i]) && !isspace(b[i])) {
7996                 tmpspec[j++] = b[i++];
7997                 if (j >= NAM$C_MAXRSS)
7998                    break;
7999             }
8000             tmpspec[j] = '\0';
8001
8002              /* There may be some default parameters to the image */
8003             /*---------------------------------------------------*/
8004             j = 0;
8005             while (isprint(b[i])) {
8006                 image_argv[j++] = b[i++];
8007                 if (j >= NAM$C_MAXRSS)
8008                    break;
8009             }
8010             while ((j > 0) && !isprint(image_argv[j-1]))
8011                 j--;
8012             image_argv[j] = 0;
8013
8014             /* It will need to be converted to VMS format and validated */
8015             if (tmpspec[0] != '\0') {
8016               char * iname;
8017
8018                /* Try to find the exact program requested to be run */
8019               /*---------------------------------------------------*/
8020               iname = do_rmsexpand
8021                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8022               if (iname != NULL) {
8023                 if (cando_by_name(S_IXUSR,0,image_name)) {
8024                   /* MCR prefix needed */
8025                   isdcl = 0;
8026                 }
8027                 else {
8028                    /* Try again with a null type */
8029                   /*----------------------------*/
8030                   iname = do_rmsexpand
8031                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8032                   if (iname != NULL) {
8033                     if (cando_by_name(S_IXUSR,0,image_name)) {
8034                       /* MCR prefix needed */
8035                       isdcl = 0;
8036                     }
8037                   }
8038                 }
8039
8040                  /* Did we find the image to run the script? */
8041                 /*------------------------------------------*/
8042                 if (isdcl) {
8043                   char *tchr;
8044
8045                    /* Assume DCL or foreign command exists */
8046                   /*--------------------------------------*/
8047                   tchr = strrchr(tmpspec, '/');
8048                   if (tchr != NULL) {
8049                     tchr++;
8050                   }
8051                   else {
8052                     tchr = tmpspec;
8053                   }
8054                   strcpy(image_name, tchr);
8055                 }
8056               }
8057             }
8058           }
8059         }
8060         fclose(fp);
8061       }
8062       if (check_img && isdcl) return RMS$_FNF;
8063
8064       if (cando_by_name(S_IXUSR,0,resspec)) {
8065         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8066         if (!isdcl) {
8067             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8068             if (image_name[0] != 0) {
8069                 strcat(vmscmd->dsc$a_pointer, image_name);
8070                 strcat(vmscmd->dsc$a_pointer, " ");
8071             }
8072         } else if (image_name[0] != 0) {
8073             strcpy(vmscmd->dsc$a_pointer, image_name);
8074             strcat(vmscmd->dsc$a_pointer, " ");
8075         } else {
8076             strcpy(vmscmd->dsc$a_pointer,"@");
8077         }
8078         if (suggest_quote) *suggest_quote = 1;
8079
8080         /* If there is an image name, use original command */
8081         if (image_name[0] == 0)
8082             strcat(vmscmd->dsc$a_pointer,resspec);
8083         else {
8084             rest = cmd;
8085             while (*rest && isspace(*rest)) rest++;
8086         }
8087
8088         if (image_argv[0] != 0) {
8089           strcat(vmscmd->dsc$a_pointer,image_argv);
8090           strcat(vmscmd->dsc$a_pointer, " ");
8091         }
8092         if (rest) {
8093            int rest_len;
8094            int vmscmd_len;
8095
8096            rest_len = strlen(rest);
8097            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8098            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8099               strcat(vmscmd->dsc$a_pointer,rest);
8100            else
8101              retsts = CLI$_BUFOVF;
8102         }
8103         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8104         Safefree(cmd);
8105         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8106       }
8107       else retsts = RMS$_PRV;
8108     }
8109   }
8110   /* It's either a DCL command or we couldn't find a suitable image */
8111   vmscmd->dsc$w_length = strlen(cmd);
8112 /*  if (cmd == PL_Cmd) {
8113       vmscmd->dsc$a_pointer = PL_Cmd;
8114       if (suggest_quote) *suggest_quote = 1;
8115   }
8116   else  */
8117       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8118
8119   Safefree(cmd);
8120
8121   /* check if it's a symbol (for quoting purposes) */
8122   if (suggest_quote && !*suggest_quote) {
8123     int iss;
8124     char equiv[LNM$C_NAMLENGTH];
8125     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8126     eqvdsc.dsc$a_pointer = equiv;
8127
8128     iss = lib$get_symbol(vmscmd,&eqvdsc);
8129     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8130   }
8131   if (!(retsts & 1)) {
8132     /* just hand off status values likely to be due to user error */
8133     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8134         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8135        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8136     else { _ckvmssts(retsts); }
8137   }
8138
8139   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8140
8141 }  /* end of setup_cmddsc() */
8142
8143
8144 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8145 bool
8146 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8147 {
8148   if (sp > mark) {
8149     if (vfork_called) {           /* this follows a vfork - act Unixish */
8150       vfork_called--;
8151       if (vfork_called < 0) {
8152         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8153         vfork_called = 0;
8154       }
8155       else return do_aexec(really,mark,sp);
8156     }
8157                                            /* no vfork - act VMSish */
8158     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8159
8160   }
8161
8162   return FALSE;
8163 }  /* end of vms_do_aexec() */
8164 /*}}}*/
8165
8166 /* {{{bool vms_do_exec(char *cmd) */
8167 bool
8168 Perl_vms_do_exec(pTHX_ const char *cmd)
8169 {
8170   struct dsc$descriptor_s *vmscmd;
8171
8172   if (vfork_called) {             /* this follows a vfork - act Unixish */
8173     vfork_called--;
8174     if (vfork_called < 0) {
8175       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8176       vfork_called = 0;
8177     }
8178     else return do_exec(cmd);
8179   }
8180
8181   {                               /* no vfork - act VMSish */
8182     unsigned long int retsts;
8183
8184     TAINT_ENV();
8185     TAINT_PROPER("exec");
8186     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8187       retsts = lib$do_command(vmscmd);
8188
8189     switch (retsts) {
8190       case RMS$_FNF: case RMS$_DNF:
8191         set_errno(ENOENT); break;
8192       case RMS$_DIR:
8193         set_errno(ENOTDIR); break;
8194       case RMS$_DEV:
8195         set_errno(ENODEV); break;
8196       case RMS$_PRV:
8197         set_errno(EACCES); break;
8198       case RMS$_SYN:
8199         set_errno(EINVAL); break;
8200       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8201         set_errno(E2BIG); break;
8202       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8203         _ckvmssts(retsts); /* fall through */
8204       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8205         set_errno(EVMSERR);
8206     }
8207     set_vaxc_errno(retsts);
8208     if (ckWARN(WARN_EXEC)) {
8209       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8210              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8211     }
8212     vms_execfree(vmscmd);
8213   }
8214
8215   return FALSE;
8216
8217 }  /* end of vms_do_exec() */
8218 /*}}}*/
8219
8220 unsigned long int Perl_do_spawn(pTHX_ const char *);
8221
8222 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8223 unsigned long int
8224 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8225 {
8226   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8227
8228   return SS$_ABORT;
8229 }  /* end of do_aspawn() */
8230 /*}}}*/
8231
8232 /* {{{unsigned long int do_spawn(char *cmd) */
8233 unsigned long int
8234 Perl_do_spawn(pTHX_ const char *cmd)
8235 {
8236   unsigned long int sts, substs;
8237
8238   TAINT_ENV();
8239   TAINT_PROPER("spawn");
8240   if (!cmd || !*cmd) {
8241     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8242     if (!(sts & 1)) {
8243       switch (sts) {
8244         case RMS$_FNF:  case RMS$_DNF:
8245           set_errno(ENOENT); break;
8246         case RMS$_DIR:
8247           set_errno(ENOTDIR); break;
8248         case RMS$_DEV:
8249           set_errno(ENODEV); break;
8250         case RMS$_PRV:
8251           set_errno(EACCES); break;
8252         case RMS$_SYN:
8253           set_errno(EINVAL); break;
8254         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8255           set_errno(E2BIG); break;
8256         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8257           _ckvmssts(sts); /* fall through */
8258         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8259           set_errno(EVMSERR);
8260       }
8261       set_vaxc_errno(sts);
8262       if (ckWARN(WARN_EXEC)) {
8263         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8264                     Strerror(errno));
8265       }
8266     }
8267     sts = substs;
8268   }
8269   else {
8270     PerlIO * fp;
8271     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8272     if (fp != NULL)
8273       my_pclose(fp);
8274   }
8275   return sts;
8276 }  /* end of do_spawn() */
8277 /*}}}*/
8278
8279
8280 static unsigned int *sockflags, sockflagsize;
8281
8282 /*
8283  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8284  * routines found in some versions of the CRTL can't deal with sockets.
8285  * We don't shim the other file open routines since a socket isn't
8286  * likely to be opened by a name.
8287  */
8288 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8289 FILE *my_fdopen(int fd, const char *mode)
8290 {
8291   FILE *fp = fdopen(fd, mode);
8292
8293   if (fp) {
8294     unsigned int fdoff = fd / sizeof(unsigned int);
8295     Stat_t sbuf; /* native stat; we don't need flex_stat */
8296     if (!sockflagsize || fdoff > sockflagsize) {
8297       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8298       else           Newx  (sockflags,fdoff+2,unsigned int);
8299       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8300       sockflagsize = fdoff + 2;
8301     }
8302     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8303       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8304   }
8305   return fp;
8306
8307 }
8308 /*}}}*/
8309
8310
8311 /*
8312  * Clear the corresponding bit when the (possibly) socket stream is closed.
8313  * There still a small hole: we miss an implicit close which might occur
8314  * via freopen().  >> Todo
8315  */
8316 /*{{{ int my_fclose(FILE *fp)*/
8317 int my_fclose(FILE *fp) {
8318   if (fp) {
8319     unsigned int fd = fileno(fp);
8320     unsigned int fdoff = fd / sizeof(unsigned int);
8321
8322     if (sockflagsize && fdoff <= sockflagsize)
8323       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8324   }
8325   return fclose(fp);
8326 }
8327 /*}}}*/
8328
8329
8330 /*
8331  * A simple fwrite replacement which outputs itmsz*nitm chars without
8332  * introducing record boundaries every itmsz chars.
8333  * We are using fputs, which depends on a terminating null.  We may
8334  * well be writing binary data, so we need to accommodate not only
8335  * data with nulls sprinkled in the middle but also data with no null
8336  * byte at the end.
8337  */
8338 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8339 int
8340 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8341 {
8342   register char *cp, *end, *cpd, *data;
8343   register unsigned int fd = fileno(dest);
8344   register unsigned int fdoff = fd / sizeof(unsigned int);
8345   int retval;
8346   int bufsize = itmsz * nitm + 1;
8347
8348   if (fdoff < sockflagsize &&
8349       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8350     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8351     return nitm;
8352   }
8353
8354   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8355   memcpy( data, src, itmsz*nitm );
8356   data[itmsz*nitm] = '\0';
8357
8358   end = data + itmsz * nitm;
8359   retval = (int) nitm; /* on success return # items written */
8360
8361   cpd = data;
8362   while (cpd <= end) {
8363     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8364     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8365     if (cp < end)
8366       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8367     cpd = cp + 1;
8368   }
8369
8370   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8371   return retval;
8372
8373 }  /* end of my_fwrite() */
8374 /*}}}*/
8375
8376 /*{{{ int my_flush(FILE *fp)*/
8377 int
8378 Perl_my_flush(pTHX_ FILE *fp)
8379 {
8380     int res;
8381     if ((res = fflush(fp)) == 0 && fp) {
8382 #ifdef VMS_DO_SOCKETS
8383         Stat_t s;
8384         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8385 #endif
8386             res = fsync(fileno(fp));
8387     }
8388 /*
8389  * If the flush succeeded but set end-of-file, we need to clear
8390  * the error because our caller may check ferror().  BTW, this
8391  * probably means we just flushed an empty file.
8392  */
8393     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8394
8395     return res;
8396 }
8397 /*}}}*/
8398
8399 /*
8400  * Here are replacements for the following Unix routines in the VMS environment:
8401  *      getpwuid    Get information for a particular UIC or UID
8402  *      getpwnam    Get information for a named user
8403  *      getpwent    Get information for each user in the rights database
8404  *      setpwent    Reset search to the start of the rights database
8405  *      endpwent    Finish searching for users in the rights database
8406  *
8407  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8408  * (defined in pwd.h), which contains the following fields:-
8409  *      struct passwd {
8410  *              char        *pw_name;    Username (in lower case)
8411  *              char        *pw_passwd;  Hashed password
8412  *              unsigned int pw_uid;     UIC
8413  *              unsigned int pw_gid;     UIC group  number
8414  *              char        *pw_unixdir; Default device/directory (VMS-style)
8415  *              char        *pw_gecos;   Owner name
8416  *              char        *pw_dir;     Default device/directory (Unix-style)
8417  *              char        *pw_shell;   Default CLI name (eg. DCL)
8418  *      };
8419  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8420  *
8421  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8422  * not the UIC member number (eg. what's returned by getuid()),
8423  * getpwuid() can accept either as input (if uid is specified, the caller's
8424  * UIC group is used), though it won't recognise gid=0.
8425  *
8426  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8427  * information about other users in your group or in other groups, respectively.
8428  * If the required privilege is not available, then these routines fill only
8429  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8430  * string).
8431  *
8432  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8433  */
8434
8435 /* sizes of various UAF record fields */
8436 #define UAI$S_USERNAME 12
8437 #define UAI$S_IDENT    31
8438 #define UAI$S_OWNER    31
8439 #define UAI$S_DEFDEV   31
8440 #define UAI$S_DEFDIR   63
8441 #define UAI$S_DEFCLI   31
8442 #define UAI$S_PWD       8
8443
8444 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8445                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8446                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8447
8448 static char __empty[]= "";
8449 static struct passwd __passwd_empty=
8450     {(char *) __empty, (char *) __empty, 0, 0,
8451      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8452 static int contxt= 0;
8453 static struct passwd __pwdcache;
8454 static char __pw_namecache[UAI$S_IDENT+1];
8455
8456 /*
8457  * This routine does most of the work extracting the user information.
8458  */
8459 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8460 {
8461     static struct {
8462         unsigned char length;
8463         char pw_gecos[UAI$S_OWNER+1];
8464     } owner;
8465     static union uicdef uic;
8466     static struct {
8467         unsigned char length;
8468         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8469     } defdev;
8470     static struct {
8471         unsigned char length;
8472         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8473     } defdir;
8474     static struct {
8475         unsigned char length;
8476         char pw_shell[UAI$S_DEFCLI+1];
8477     } defcli;
8478     static char pw_passwd[UAI$S_PWD+1];
8479
8480     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8481     struct dsc$descriptor_s name_desc;
8482     unsigned long int sts;
8483
8484     static struct itmlst_3 itmlst[]= {
8485         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8486         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8487         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8488         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8489         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8490         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8491         {0,                0,           NULL,    NULL}};
8492
8493     name_desc.dsc$w_length=  strlen(name);
8494     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8495     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8496     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8497
8498 /*  Note that sys$getuai returns many fields as counted strings. */
8499     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8500     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8501       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8502     }
8503     else { _ckvmssts(sts); }
8504     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8505
8506     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8507     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8508     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8509     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8510     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8511     owner.pw_gecos[lowner]=            '\0';
8512     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8513     defcli.pw_shell[ldefcli]=          '\0';
8514     if (valid_uic(uic)) {
8515         pwd->pw_uid= uic.uic$l_uic;
8516         pwd->pw_gid= uic.uic$v_group;
8517     }
8518     else
8519       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8520     pwd->pw_passwd=  pw_passwd;
8521     pwd->pw_gecos=   owner.pw_gecos;
8522     pwd->pw_dir=     defdev.pw_dir;
8523     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8524     pwd->pw_shell=   defcli.pw_shell;
8525     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8526         int ldir;
8527         ldir= strlen(pwd->pw_unixdir) - 1;
8528         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8529     }
8530     else
8531         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8532     if (!decc_efs_case_preserve)
8533         __mystrtolower(pwd->pw_unixdir);
8534     return 1;
8535 }
8536
8537 /*
8538  * Get information for a named user.
8539 */
8540 /*{{{struct passwd *getpwnam(char *name)*/
8541 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8542 {
8543     struct dsc$descriptor_s name_desc;
8544     union uicdef uic;
8545     unsigned long int status, sts;
8546
8547     __pwdcache = __passwd_empty;
8548     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8549       /* We still may be able to determine pw_uid and pw_gid */
8550       name_desc.dsc$w_length=  strlen(name);
8551       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8552       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8553       name_desc.dsc$a_pointer= (char *) name;
8554       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8555         __pwdcache.pw_uid= uic.uic$l_uic;
8556         __pwdcache.pw_gid= uic.uic$v_group;
8557       }
8558       else {
8559         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8560           set_vaxc_errno(sts);
8561           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8562           return NULL;
8563         }
8564         else { _ckvmssts(sts); }
8565       }
8566     }
8567     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8568     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8569     __pwdcache.pw_name= __pw_namecache;
8570     return &__pwdcache;
8571 }  /* end of my_getpwnam() */
8572 /*}}}*/
8573
8574 /*
8575  * Get information for a particular UIC or UID.
8576  * Called by my_getpwent with uid=-1 to list all users.
8577 */
8578 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8579 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8580 {
8581     const $DESCRIPTOR(name_desc,__pw_namecache);
8582     unsigned short lname;
8583     union uicdef uic;
8584     unsigned long int status;
8585
8586     if (uid == (unsigned int) -1) {
8587       do {
8588         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8589         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8590           set_vaxc_errno(status);
8591           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8592           my_endpwent();
8593           return NULL;
8594         }
8595         else { _ckvmssts(status); }
8596       } while (!valid_uic (uic));
8597     }
8598     else {
8599       uic.uic$l_uic= uid;
8600       if (!uic.uic$v_group)
8601         uic.uic$v_group= PerlProc_getgid();
8602       if (valid_uic(uic))
8603         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8604       else status = SS$_IVIDENT;
8605       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8606           status == RMS$_PRV) {
8607         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8608         return NULL;
8609       }
8610       else { _ckvmssts(status); }
8611     }
8612     __pw_namecache[lname]= '\0';
8613     __mystrtolower(__pw_namecache);
8614
8615     __pwdcache = __passwd_empty;
8616     __pwdcache.pw_name = __pw_namecache;
8617
8618 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8619     The identifier's value is usually the UIC, but it doesn't have to be,
8620     so if we can, we let fillpasswd update this. */
8621     __pwdcache.pw_uid =  uic.uic$l_uic;
8622     __pwdcache.pw_gid =  uic.uic$v_group;
8623
8624     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8625     return &__pwdcache;
8626
8627 }  /* end of my_getpwuid() */
8628 /*}}}*/
8629
8630 /*
8631  * Get information for next user.
8632 */
8633 /*{{{struct passwd *my_getpwent()*/
8634 struct passwd *Perl_my_getpwent(pTHX)
8635 {
8636     return (my_getpwuid((unsigned int) -1));
8637 }
8638 /*}}}*/
8639
8640 /*
8641  * Finish searching rights database for users.
8642 */
8643 /*{{{void my_endpwent()*/
8644 void Perl_my_endpwent(pTHX)
8645 {
8646     if (contxt) {
8647       _ckvmssts(sys$finish_rdb(&contxt));
8648       contxt= 0;
8649     }
8650 }
8651 /*}}}*/
8652
8653 #ifdef HOMEGROWN_POSIX_SIGNALS
8654   /* Signal handling routines, pulled into the core from POSIX.xs.
8655    *
8656    * We need these for threads, so they've been rolled into the core,
8657    * rather than left in POSIX.xs.
8658    *
8659    * (DRS, Oct 23, 1997)
8660    */
8661
8662   /* sigset_t is atomic under VMS, so these routines are easy */
8663 /*{{{int my_sigemptyset(sigset_t *) */
8664 int my_sigemptyset(sigset_t *set) {
8665     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8666     *set = 0; return 0;
8667 }
8668 /*}}}*/
8669
8670
8671 /*{{{int my_sigfillset(sigset_t *)*/
8672 int my_sigfillset(sigset_t *set) {
8673     int i;
8674     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8675     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8676     return 0;
8677 }
8678 /*}}}*/
8679
8680
8681 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8682 int my_sigaddset(sigset_t *set, int sig) {
8683     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8684     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8685     *set |= (1 << (sig - 1));
8686     return 0;
8687 }
8688 /*}}}*/
8689
8690
8691 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8692 int my_sigdelset(sigset_t *set, int sig) {
8693     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8694     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8695     *set &= ~(1 << (sig - 1));
8696     return 0;
8697 }
8698 /*}}}*/
8699
8700
8701 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8702 int my_sigismember(sigset_t *set, int sig) {
8703     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8704     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8705     return *set & (1 << (sig - 1));
8706 }
8707 /*}}}*/
8708
8709
8710 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8711 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8712     sigset_t tempmask;
8713
8714     /* If set and oset are both null, then things are badly wrong. Bail out. */
8715     if ((oset == NULL) && (set == NULL)) {
8716       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8717       return -1;
8718     }
8719
8720     /* If set's null, then we're just handling a fetch. */
8721     if (set == NULL) {
8722         tempmask = sigblock(0);
8723     }
8724     else {
8725       switch (how) {
8726       case SIG_SETMASK:
8727         tempmask = sigsetmask(*set);
8728         break;
8729       case SIG_BLOCK:
8730         tempmask = sigblock(*set);
8731         break;
8732       case SIG_UNBLOCK:
8733         tempmask = sigblock(0);
8734         sigsetmask(*oset & ~tempmask);
8735         break;
8736       default:
8737         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8738         return -1;
8739       }
8740     }
8741
8742     /* Did they pass us an oset? If so, stick our holding mask into it */
8743     if (oset)
8744       *oset = tempmask;
8745
8746     return 0;
8747 }
8748 /*}}}*/
8749 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8750
8751
8752 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8753  * my_utime(), and flex_stat(), all of which operate on UTC unless
8754  * VMSISH_TIMES is true.
8755  */
8756 /* method used to handle UTC conversions:
8757  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8758  */
8759 static int gmtime_emulation_type;
8760 /* number of secs to add to UTC POSIX-style time to get local time */
8761 static long int utc_offset_secs;
8762
8763 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8764  * in vmsish.h.  #undef them here so we can call the CRTL routines
8765  * directly.
8766  */
8767 #undef gmtime
8768 #undef localtime
8769 #undef time
8770
8771
8772 /*
8773  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8774  * qualifier with the extern prefix pragma.  This provisional
8775  * hack circumvents this prefix pragma problem in previous
8776  * precompilers.
8777  */
8778 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8779 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8780 #    pragma __extern_prefix save
8781 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8782 #    define gmtime decc$__utctz_gmtime
8783 #    define localtime decc$__utctz_localtime
8784 #    define time decc$__utc_time
8785 #    pragma __extern_prefix restore
8786
8787      struct tm *gmtime(), *localtime();
8788
8789 #  endif
8790 #endif
8791
8792
8793 static time_t toutc_dst(time_t loc) {
8794   struct tm *rsltmp;
8795
8796   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8797   loc -= utc_offset_secs;
8798   if (rsltmp->tm_isdst) loc -= 3600;
8799   return loc;
8800 }
8801 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8802        ((gmtime_emulation_type || my_time(NULL)), \
8803        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8804        ((secs) - utc_offset_secs))))
8805
8806 static time_t toloc_dst(time_t utc) {
8807   struct tm *rsltmp;
8808
8809   utc += utc_offset_secs;
8810   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8811   if (rsltmp->tm_isdst) utc += 3600;
8812   return utc;
8813 }
8814 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8815        ((gmtime_emulation_type || my_time(NULL)), \
8816        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8817        ((secs) + utc_offset_secs))))
8818
8819 #ifndef RTL_USES_UTC
8820 /*
8821
8822     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8823         DST starts on 1st sun of april      at 02:00  std time
8824             ends on last sun of october     at 02:00  dst time
8825     see the UCX management command reference, SET CONFIG TIMEZONE
8826     for formatting info.
8827
8828     No, it's not as general as it should be, but then again, NOTHING
8829     will handle UK times in a sensible way.
8830 */
8831
8832
8833 /*
8834     parse the DST start/end info:
8835     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8836 */
8837
8838 static char *
8839 tz_parse_startend(char *s, struct tm *w, int *past)
8840 {
8841     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8842     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8843     time_t g;
8844
8845     if (!s)    return 0;
8846     if (!w) return 0;
8847     if (!past) return 0;
8848
8849     ly = 0;
8850     if (w->tm_year % 4        == 0) ly = 1;
8851     if (w->tm_year % 100      == 0) ly = 0;
8852     if (w->tm_year+1900 % 400 == 0) ly = 1;
8853     if (ly) dinm[1]++;
8854
8855     dozjd = isdigit(*s);
8856     if (*s == 'J' || *s == 'j' || dozjd) {
8857         if (!dozjd && !isdigit(*++s)) return 0;
8858         d = *s++ - '0';
8859         if (isdigit(*s)) {
8860             d = d*10 + *s++ - '0';
8861             if (isdigit(*s)) {
8862                 d = d*10 + *s++ - '0';
8863             }
8864         }
8865         if (d == 0) return 0;
8866         if (d > 366) return 0;
8867         d--;
8868         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8869         g = d * 86400;
8870         dozjd = 1;
8871     } else if (*s == 'M' || *s == 'm') {
8872         if (!isdigit(*++s)) return 0;
8873         m = *s++ - '0';
8874         if (isdigit(*s)) m = 10*m + *s++ - '0';
8875         if (*s != '.') return 0;
8876         if (!isdigit(*++s)) return 0;
8877         n = *s++ - '0';
8878         if (n < 1 || n > 5) return 0;
8879         if (*s != '.') return 0;
8880         if (!isdigit(*++s)) return 0;
8881         d = *s++ - '0';
8882         if (d > 6) return 0;
8883     }
8884
8885     if (*s == '/') {
8886         if (!isdigit(*++s)) return 0;
8887         hour = *s++ - '0';
8888         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8889         if (*s == ':') {
8890             if (!isdigit(*++s)) return 0;
8891             min = *s++ - '0';
8892             if (isdigit(*s)) min = 10*min + *s++ - '0';
8893             if (*s == ':') {
8894                 if (!isdigit(*++s)) return 0;
8895                 sec = *s++ - '0';
8896                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8897             }
8898         }
8899     } else {
8900         hour = 2;
8901         min = 0;
8902         sec = 0;
8903     }
8904
8905     if (dozjd) {
8906         if (w->tm_yday < d) goto before;
8907         if (w->tm_yday > d) goto after;
8908     } else {
8909         if (w->tm_mon+1 < m) goto before;
8910         if (w->tm_mon+1 > m) goto after;
8911
8912         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8913         k = d - j; /* mday of first d */
8914         if (k <= 0) k += 7;
8915         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8916         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8917         if (w->tm_mday < k) goto before;
8918         if (w->tm_mday > k) goto after;
8919     }
8920
8921     if (w->tm_hour < hour) goto before;
8922     if (w->tm_hour > hour) goto after;
8923     if (w->tm_min  < min)  goto before;
8924     if (w->tm_min  > min)  goto after;
8925     if (w->tm_sec  < sec)  goto before;
8926     goto after;
8927
8928 before:
8929     *past = 0;
8930     return s;
8931 after:
8932     *past = 1;
8933     return s;
8934 }
8935
8936
8937
8938
8939 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8940
8941 static char *
8942 tz_parse_offset(char *s, int *offset)
8943 {
8944     int hour = 0, min = 0, sec = 0;
8945     int neg = 0;
8946     if (!s) return 0;
8947     if (!offset) return 0;
8948
8949     if (*s == '-') {neg++; s++;}
8950     if (*s == '+') s++;
8951     if (!isdigit(*s)) return 0;
8952     hour = *s++ - '0';
8953     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8954     if (hour > 24) return 0;
8955     if (*s == ':') {
8956         if (!isdigit(*++s)) return 0;
8957         min = *s++ - '0';
8958         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8959         if (min > 59) return 0;
8960         if (*s == ':') {
8961             if (!isdigit(*++s)) return 0;
8962             sec = *s++ - '0';
8963             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8964             if (sec > 59) return 0;
8965         }
8966     }
8967
8968     *offset = (hour*60+min)*60 + sec;
8969     if (neg) *offset = -*offset;
8970     return s;
8971 }
8972
8973 /*
8974     input time is w, whatever type of time the CRTL localtime() uses.
8975     sets dst, the zone, and the gmtoff (seconds)
8976
8977     caches the value of TZ and UCX$TZ env variables; note that
8978     my_setenv looks for these and sets a flag if they're changed
8979     for efficiency.
8980
8981     We have to watch out for the "australian" case (dst starts in
8982     october, ends in april)...flagged by "reverse" and checked by
8983     scanning through the months of the previous year.
8984
8985 */
8986
8987 static int
8988 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8989 {
8990     time_t when;
8991     struct tm *w2;
8992     char *s,*s2;
8993     char *dstzone, *tz, *s_start, *s_end;
8994     int std_off, dst_off, isdst;
8995     int y, dststart, dstend;
8996     static char envtz[1025];  /* longer than any logical, symbol, ... */
8997     static char ucxtz[1025];
8998     static char reversed = 0;
8999
9000     if (!w) return 0;
9001
9002     if (tz_updated) {
9003         tz_updated = 0;
9004         reversed = -1;  /* flag need to check  */
9005         envtz[0] = ucxtz[0] = '\0';
9006         tz = my_getenv("TZ",0);
9007         if (tz) strcpy(envtz, tz);
9008         tz = my_getenv("UCX$TZ",0);
9009         if (tz) strcpy(ucxtz, tz);
9010         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9011     }
9012     tz = envtz;
9013     if (!*tz) tz = ucxtz;
9014
9015     s = tz;
9016     while (isalpha(*s)) s++;
9017     s = tz_parse_offset(s, &std_off);
9018     if (!s) return 0;
9019     if (!*s) {                  /* no DST, hurray we're done! */
9020         isdst = 0;
9021         goto done;
9022     }
9023
9024     dstzone = s;
9025     while (isalpha(*s)) s++;
9026     s2 = tz_parse_offset(s, &dst_off);
9027     if (s2) {
9028         s = s2;
9029     } else {
9030         dst_off = std_off - 3600;
9031     }
9032
9033     if (!*s) {      /* default dst start/end?? */
9034         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9035             s = strchr(ucxtz,',');
9036         }
9037         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9038     }
9039     if (*s != ',') return 0;
9040
9041     when = *w;
9042     when = _toutc(when);      /* convert to utc */
9043     when = when - std_off;    /* convert to pseudolocal time*/
9044
9045     w2 = localtime(&when);
9046     y = w2->tm_year;
9047     s_start = s+1;
9048     s = tz_parse_startend(s_start,w2,&dststart);
9049     if (!s) return 0;
9050     if (*s != ',') return 0;
9051
9052     when = *w;
9053     when = _toutc(when);      /* convert to utc */
9054     when = when - dst_off;    /* convert to pseudolocal time*/
9055     w2 = localtime(&when);
9056     if (w2->tm_year != y) {   /* spans a year, just check one time */
9057         when += dst_off - std_off;
9058         w2 = localtime(&when);
9059     }
9060     s_end = s+1;
9061     s = tz_parse_startend(s_end,w2,&dstend);
9062     if (!s) return 0;
9063
9064     if (reversed == -1) {  /* need to check if start later than end */
9065         int j, ds, de;
9066
9067         when = *w;
9068         if (when < 2*365*86400) {
9069             when += 2*365*86400;
9070         } else {
9071             when -= 365*86400;
9072         }
9073         w2 =localtime(&when);
9074         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9075
9076         for (j = 0; j < 12; j++) {
9077             w2 =localtime(&when);
9078             tz_parse_startend(s_start,w2,&ds);
9079             tz_parse_startend(s_end,w2,&de);
9080             if (ds != de) break;
9081             when += 30*86400;
9082         }
9083         reversed = 0;
9084         if (de && !ds) reversed = 1;
9085     }
9086
9087     isdst = dststart && !dstend;
9088     if (reversed) isdst = dststart  || !dstend;
9089
9090 done:
9091     if (dst)    *dst = isdst;
9092     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9093     if (isdst)  tz = dstzone;
9094     if (zone) {
9095         while(isalpha(*tz))  *zone++ = *tz++;
9096         *zone = '\0';
9097     }
9098     return 1;
9099 }
9100
9101 #endif /* !RTL_USES_UTC */
9102
9103 /* my_time(), my_localtime(), my_gmtime()
9104  * By default traffic in UTC time values, using CRTL gmtime() or
9105  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9106  * Note: We need to use these functions even when the CRTL has working
9107  * UTC support, since they also handle C<use vmsish qw(times);>
9108  *
9109  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9110  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9111  */
9112
9113 /*{{{time_t my_time(time_t *timep)*/
9114 time_t Perl_my_time(pTHX_ time_t *timep)
9115 {
9116   time_t when;
9117   struct tm *tm_p;
9118
9119   if (gmtime_emulation_type == 0) {
9120     int dstnow;
9121     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9122                               /* results of calls to gmtime() and localtime() */
9123                               /* for same &base */
9124
9125     gmtime_emulation_type++;
9126     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9127       char off[LNM$C_NAMLENGTH+1];;
9128
9129       gmtime_emulation_type++;
9130       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9131         gmtime_emulation_type++;
9132         utc_offset_secs = 0;
9133         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9134       }
9135       else { utc_offset_secs = atol(off); }
9136     }
9137     else { /* We've got a working gmtime() */
9138       struct tm gmt, local;
9139
9140       gmt = *tm_p;
9141       tm_p = localtime(&base);
9142       local = *tm_p;
9143       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9144       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9145       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9146       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9147     }
9148   }
9149
9150   when = time(NULL);
9151 # ifdef VMSISH_TIME
9152 # ifdef RTL_USES_UTC
9153   if (VMSISH_TIME) when = _toloc(when);
9154 # else
9155   if (!VMSISH_TIME) when = _toutc(when);
9156 # endif
9157 # endif
9158   if (timep != NULL) *timep = when;
9159   return when;
9160
9161 }  /* end of my_time() */
9162 /*}}}*/
9163
9164
9165 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9166 struct tm *
9167 Perl_my_gmtime(pTHX_ const time_t *timep)
9168 {
9169   char *p;
9170   time_t when;
9171   struct tm *rsltmp;
9172
9173   if (timep == NULL) {
9174     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9175     return NULL;
9176   }
9177   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9178
9179   when = *timep;
9180 # ifdef VMSISH_TIME
9181   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9182 #  endif
9183 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9184   return gmtime(&when);
9185 # else
9186   /* CRTL localtime() wants local time as input, so does no tz correction */
9187   rsltmp = localtime(&when);
9188   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9189   return rsltmp;
9190 #endif
9191 }  /* end of my_gmtime() */
9192 /*}}}*/
9193
9194
9195 /*{{{struct tm *my_localtime(const time_t *timep)*/
9196 struct tm *
9197 Perl_my_localtime(pTHX_ const time_t *timep)
9198 {
9199   time_t when, whenutc;
9200   struct tm *rsltmp;
9201   int dst, offset;
9202
9203   if (timep == NULL) {
9204     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9205     return NULL;
9206   }
9207   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9208   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9209
9210   when = *timep;
9211 # ifdef RTL_USES_UTC
9212 # ifdef VMSISH_TIME
9213   if (VMSISH_TIME) when = _toutc(when);
9214 # endif
9215   /* CRTL localtime() wants UTC as input, does tz correction itself */
9216   return localtime(&when);
9217
9218 # else /* !RTL_USES_UTC */
9219   whenutc = when;
9220 # ifdef VMSISH_TIME
9221   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9222   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9223 # endif
9224   dst = -1;
9225 #ifndef RTL_USES_UTC
9226   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9227       when = whenutc - offset;                   /* pseudolocal time*/
9228   }
9229 # endif
9230   /* CRTL localtime() wants local time as input, so does no tz correction */
9231   rsltmp = localtime(&when);
9232   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9233   return rsltmp;
9234 # endif
9235
9236 } /*  end of my_localtime() */
9237 /*}}}*/
9238
9239 /* Reset definitions for later calls */
9240 #define gmtime(t)    my_gmtime(t)
9241 #define localtime(t) my_localtime(t)
9242 #define time(t)      my_time(t)
9243
9244
9245 /* my_utime - update modification time of a file
9246  * calling sequence is identical to POSIX utime(), but under
9247  * VMS only the modification time is changed; ODS-2 does not
9248  * maintain access times.  Restrictions differ from the POSIX
9249  * definition in that the time can be changed as long as the
9250  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9251  * no separate checks are made to insure that the caller is the
9252  * owner of the file or has special privs enabled.
9253  * Code here is based on Joe Meadows' FILE utility.
9254  */
9255
9256 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9257  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9258  * in 100 ns intervals.
9259  */
9260 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9261
9262 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9263 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9264 {
9265   register int i;
9266   int sts;
9267   long int bintime[2], len = 2, lowbit, unixtime,
9268            secscale = 10000000; /* seconds --> 100 ns intervals */
9269   unsigned long int chan, iosb[2], retsts;
9270   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9271   struct FAB myfab = cc$rms_fab;
9272   struct NAM mynam = cc$rms_nam;
9273 #if defined (__DECC) && defined (__VAX)
9274   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9275    * at least through VMS V6.1, which causes a type-conversion warning.
9276    */
9277 #  pragma message save
9278 #  pragma message disable cvtdiftypes
9279 #endif
9280   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9281   struct fibdef myfib;
9282 #if defined (__DECC) && defined (__VAX)
9283   /* This should be right after the declaration of myatr, but due
9284    * to a bug in VAX DEC C, this takes effect a statement early.
9285    */
9286 #  pragma message restore
9287 #endif
9288   /* cast ok for read only parameter */
9289   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9290                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9291                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9292
9293   if (file == NULL || *file == '\0') {
9294     set_errno(ENOENT);
9295     set_vaxc_errno(LIB$_INVARG);
9296     return -1;
9297   }
9298   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9299
9300   if (utimes != NULL) {
9301     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9302      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9303      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9304      * as input, we force the sign bit to be clear by shifting unixtime right
9305      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9306      */
9307     lowbit = (utimes->modtime & 1) ? secscale : 0;
9308     unixtime = (long int) utimes->modtime;
9309 #   ifdef VMSISH_TIME
9310     /* If input was UTC; convert to local for sys svc */
9311     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9312 #   endif
9313     unixtime >>= 1;  secscale <<= 1;
9314     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9315     if (!(retsts & 1)) {
9316       set_errno(EVMSERR);
9317       set_vaxc_errno(retsts);
9318       return -1;
9319     }
9320     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9321     if (!(retsts & 1)) {
9322       set_errno(EVMSERR);
9323       set_vaxc_errno(retsts);
9324       return -1;
9325     }
9326   }
9327   else {
9328     /* Just get the current time in VMS format directly */
9329     retsts = sys$gettim(bintime);
9330     if (!(retsts & 1)) {
9331       set_errno(EVMSERR);
9332       set_vaxc_errno(retsts);
9333       return -1;
9334     }
9335   }
9336
9337   myfab.fab$l_fna = vmsspec;
9338   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9339   myfab.fab$l_nam = &mynam;
9340   mynam.nam$l_esa = esa;
9341   mynam.nam$b_ess = (unsigned char) sizeof esa;
9342   mynam.nam$l_rsa = rsa;
9343   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9344   if (decc_efs_case_preserve)
9345       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9346
9347   /* Look for the file to be affected, letting RMS parse the file
9348    * specification for us as well.  I have set errno using only
9349    * values documented in the utime() man page for VMS POSIX.
9350    */
9351   retsts = sys$parse(&myfab,0,0);
9352   if (!(retsts & 1)) {
9353     set_vaxc_errno(retsts);
9354     if      (retsts == RMS$_PRV) set_errno(EACCES);
9355     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9356     else                         set_errno(EVMSERR);
9357     return -1;
9358   }
9359   retsts = sys$search(&myfab,0,0);
9360   if (!(retsts & 1)) {
9361     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9362     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9363     set_vaxc_errno(retsts);
9364     if      (retsts == RMS$_PRV) set_errno(EACCES);
9365     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9366     else                         set_errno(EVMSERR);
9367     return -1;
9368   }
9369
9370   devdsc.dsc$w_length = mynam.nam$b_dev;
9371   /* cast ok for read only parameter */
9372   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9373
9374   retsts = sys$assign(&devdsc,&chan,0,0);
9375   if (!(retsts & 1)) {
9376     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9377     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9378     set_vaxc_errno(retsts);
9379     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9380     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9381     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9382     else                               set_errno(EVMSERR);
9383     return -1;
9384   }
9385
9386   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9387   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9388
9389   memset((void *) &myfib, 0, sizeof myfib);
9390 #if defined(__DECC) || defined(__DECCXX)
9391   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9392   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9393   /* This prevents the revision time of the file being reset to the current
9394    * time as a result of our IO$_MODIFY $QIO. */
9395   myfib.fib$l_acctl = FIB$M_NORECORD;
9396 #else
9397   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9398   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9399   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9400 #endif
9401   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9402   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9403   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9404   _ckvmssts(sys$dassgn(chan));
9405   if (retsts & 1) retsts = iosb[0];
9406   if (!(retsts & 1)) {
9407     set_vaxc_errno(retsts);
9408     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9409     else                      set_errno(EVMSERR);
9410     return -1;
9411   }
9412
9413   return 0;
9414 }  /* end of my_utime() */
9415 /*}}}*/
9416
9417 /*
9418  * flex_stat, flex_lstat, flex_fstat
9419  * basic stat, but gets it right when asked to stat
9420  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9421  */
9422
9423 #ifndef _USE_STD_STAT
9424 /* encode_dev packs a VMS device name string into an integer to allow
9425  * simple comparisons. This can be used, for example, to check whether two
9426  * files are located on the same device, by comparing their encoded device
9427  * names. Even a string comparison would not do, because stat() reuses the
9428  * device name buffer for each call; so without encode_dev, it would be
9429  * necessary to save the buffer and use strcmp (this would mean a number of
9430  * changes to the standard Perl code, to say nothing of what a Perl script
9431  * would have to do.
9432  *
9433  * The device lock id, if it exists, should be unique (unless perhaps compared
9434  * with lock ids transferred from other nodes). We have a lock id if the disk is
9435  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9436  * device names. Thus we use the lock id in preference, and only if that isn't
9437  * available, do we try to pack the device name into an integer (flagged by
9438  * the sign bit (LOCKID_MASK) being set).
9439  *
9440  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9441  * name and its encoded form, but it seems very unlikely that we will find
9442  * two files on different disks that share the same encoded device names,
9443  * and even more remote that they will share the same file id (if the test
9444  * is to check for the same file).
9445  *
9446  * A better method might be to use sys$device_scan on the first call, and to
9447  * search for the device, returning an index into the cached array.
9448  * The number returned would be more intelligable.
9449  * This is probably not worth it, and anyway would take quite a bit longer
9450  * on the first call.
9451  */
9452 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9453 static mydev_t encode_dev (pTHX_ const char *dev)
9454 {
9455   int i;
9456   unsigned long int f;
9457   mydev_t enc;
9458   char c;
9459   const char *q;
9460
9461   if (!dev || !dev[0]) return 0;
9462
9463 #if LOCKID_MASK
9464   {
9465     struct dsc$descriptor_s dev_desc;
9466     unsigned long int status, lockid, item = DVI$_LOCKID;
9467
9468     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9469        can try that first. */
9470     dev_desc.dsc$w_length =  strlen (dev);
9471     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9472     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9473     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9474     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9475     if (lockid) return (lockid & ~LOCKID_MASK);
9476   }
9477 #endif
9478
9479   /* Otherwise we try to encode the device name */
9480   enc = 0;
9481   f = 1;
9482   i = 0;
9483   for (q = dev + strlen(dev); q--; q >= dev) {
9484     if (isdigit (*q))
9485       c= (*q) - '0';
9486     else if (isalpha (toupper (*q)))
9487       c= toupper (*q) - 'A' + (char)10;
9488     else
9489       continue; /* Skip '$'s */
9490     i++;
9491     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9492     if (i>1) f *= 36;
9493     enc += f * (unsigned long int) c;
9494   }
9495   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9496
9497 }  /* end of encode_dev() */
9498 #endif
9499
9500 static char namecache[NAM$C_MAXRSS+1];
9501
9502 static int
9503 is_null_device(name)
9504     const char *name;
9505 {
9506   if (decc_bug_devnull != 0) {
9507     if (strcmp("/dev/null", name) == 0) /* temp hack */
9508       return 1;
9509   }
9510     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9511        The underscore prefix, controller letter, and unit number are
9512        independently optional; for our purposes, the colon punctuation
9513        is not.  The colon can be trailed by optional directory and/or
9514        filename, but two consecutive colons indicates a nodename rather
9515        than a device.  [pr]  */
9516   if (*name == '_') ++name;
9517   if (tolower(*name++) != 'n') return 0;
9518   if (tolower(*name++) != 'l') return 0;
9519   if (tolower(*name) == 'a') ++name;
9520   if (*name == '0') ++name;
9521   return (*name++ == ':') && (*name != ':');
9522 }
9523
9524 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9525 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9526  * subset of the applicable information.
9527  */
9528 bool
9529 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9530 {
9531   char fname_phdev[NAM$C_MAXRSS+1];
9532 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9533   /* Namecache not workable with symbolic links, as symbolic links do
9534    *  not have extensions and directories do in VMS mode.  So in order
9535    *  to test this, the did and ino_t must be used.
9536    *
9537    * Fix-me - Hide the information in the new stat structure
9538    *          Get rid of the namecache.
9539    */
9540   if (decc_posix_compliant_pathnames == 0)
9541 #endif
9542       if (statbufp == &PL_statcache)
9543           return cando_by_name(bit,effective,namecache);
9544   {
9545     char fname[NAM$C_MAXRSS+1];
9546     unsigned long int retsts;
9547     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9548                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9549
9550     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9551        device name on successive calls */
9552     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9553     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9554     namdsc.dsc$a_pointer = fname;
9555     namdsc.dsc$w_length = sizeof fname - 1;
9556
9557     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9558                              &namdsc,&namdsc.dsc$w_length,0,0);
9559     if (retsts & 1) {
9560       fname[namdsc.dsc$w_length] = '\0';
9561 /*
9562  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9563  * but if someone has redefined that logical, Perl gets very lost.  Since
9564  * we have the physical device name from the stat buffer, just paste it on.
9565  */
9566       strcpy( fname_phdev, statbufp->st_devnam );
9567       strcat( fname_phdev, strrchr(fname, ':') );
9568
9569       return cando_by_name(bit,effective,fname_phdev);
9570     }
9571     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9572       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9573       return FALSE;
9574     }
9575     _ckvmssts(retsts);
9576     return FALSE;  /* Should never get to here */
9577   }
9578 }  /* end of cando() */
9579 /*}}}*/
9580
9581
9582 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9583 I32
9584 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9585 {
9586   static char usrname[L_cuserid];
9587   static struct dsc$descriptor_s usrdsc =
9588          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9589   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9590   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9591   unsigned short int retlen, trnlnm_iter_count;
9592   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9593   union prvdef curprv;
9594   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9595          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9596   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9597          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9598          {0,0,0,0}};
9599   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9600          {0,0,0,0}};
9601   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9602
9603   if (!fname || !*fname) return FALSE;
9604   /* Make sure we expand logical names, since sys$check_access doesn't */
9605   if (!strpbrk(fname,"/]>:")) {
9606     strcpy(fileified,fname);
9607     trnlnm_iter_count = 0;
9608     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9609         trnlnm_iter_count++;
9610         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9611     }
9612     fname = fileified;
9613   }
9614   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9615   retlen = namdsc.dsc$w_length = strlen(vmsname);
9616   namdsc.dsc$a_pointer = vmsname;
9617   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9618       vmsname[retlen-1] == ':') {
9619     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9620     namdsc.dsc$w_length = strlen(fileified);
9621     namdsc.dsc$a_pointer = fileified;
9622   }
9623
9624   switch (bit) {
9625     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9626       access = ARM$M_EXECUTE; break;
9627     case S_IRUSR: case S_IRGRP: case S_IROTH:
9628       access = ARM$M_READ; break;
9629     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9630       access = ARM$M_WRITE; break;
9631     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9632       access = ARM$M_DELETE; break;
9633     default:
9634       return FALSE;
9635   }
9636
9637   /* Before we call $check_access, create a user profile with the current
9638    * process privs since otherwise it just uses the default privs from the
9639    * UAF and might give false positives or negatives.  This only works on
9640    * VMS versions v6.0 and later since that's when sys$create_user_profile
9641    * became available.
9642    */
9643
9644   /* get current process privs and username */
9645   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9646   _ckvmssts(iosb[0]);
9647
9648 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9649
9650   /* find out the space required for the profile */
9651   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9652                                     &usrprodsc.dsc$w_length,0));
9653
9654   /* allocate space for the profile and get it filled in */
9655   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9656   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9657                                     &usrprodsc.dsc$w_length,0));
9658
9659   /* use the profile to check access to the file; free profile & analyze results */
9660   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9661   Safefree(usrprodsc.dsc$a_pointer);
9662   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9663
9664 #else
9665
9666   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9667
9668 #endif
9669
9670   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9671       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9672       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9673     set_vaxc_errno(retsts);
9674     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9675     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9676     else set_errno(ENOENT);
9677     return FALSE;
9678   }
9679   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9680     return TRUE;
9681   }
9682   _ckvmssts(retsts);
9683
9684   return FALSE;  /* Should never get here */
9685
9686 }  /* end of cando_by_name() */
9687 /*}}}*/
9688
9689
9690 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9691 int
9692 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9693 {
9694   if (!fstat(fd,(stat_t *) statbufp)) {
9695     if (statbufp == (Stat_t *) &PL_statcache) {
9696     char *cptr;
9697
9698         /* Save name for cando by name in VMS format */
9699         cptr = getname(fd, namecache, 1);
9700
9701         /* This should not happen, but just in case */
9702         if (cptr == NULL)
9703            namecache[0] = '\0';
9704     }
9705 #ifdef _USE_STD_STAT
9706     memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9707 #else
9708     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9709 #endif
9710 #ifndef _USE_STD_STAT
9711     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9712     statbufp->st_devnam[63] = 0;
9713     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9714 #else
9715     /* todo:
9716      * The device is only encoded so that Perl_cando can use it to
9717      * look up ACLS.  So rmsexpand it to the 255 character version
9718      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9719      * for long filenames and symbolic links first.  This also seems
9720      * to remove the need for a namecache that could be stale.
9721      */
9722 #endif
9723
9724 #   ifdef RTL_USES_UTC
9725 #   ifdef VMSISH_TIME
9726     if (VMSISH_TIME) {
9727       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9728       statbufp->st_atime = _toloc(statbufp->st_atime);
9729       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9730     }
9731 #   endif
9732 #   else
9733 #   ifdef VMSISH_TIME
9734     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9735 #   else
9736     if (1) {
9737 #   endif
9738       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9739       statbufp->st_atime = _toutc(statbufp->st_atime);
9740       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9741     }
9742 #endif
9743     return 0;
9744   }
9745   return -1;
9746
9747 }  /* end of flex_fstat() */
9748 /*}}}*/
9749
9750 #if !defined(__VAX) && __CRTL_VER >= 80200000
9751 #ifdef lstat
9752 #undef lstat
9753 #endif
9754 #else
9755 #ifdef lstat
9756 #undef lstat
9757 #endif
9758 #define lstat(_x, _y) stat(_x, _y)
9759 #endif
9760
9761 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9762
9763 static int
9764 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9765 {
9766     char fileified[NAM$C_MAXRSS+1];
9767     char temp_fspec[NAM$C_MAXRSS+300];
9768     int retval = -1;
9769     int saved_errno, saved_vaxc_errno;
9770
9771     if (!fspec) return retval;
9772     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9773     strcpy(temp_fspec, fspec);
9774     if (statbufp == (Stat_t *) &PL_statcache)
9775       do_tovmsspec(temp_fspec,namecache,0);
9776     if (decc_bug_devnull != 0) {
9777       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9778         memset(statbufp,0,sizeof *statbufp);
9779         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9780         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9781         statbufp->st_uid = 0x00010001;
9782         statbufp->st_gid = 0x0001;
9783         time((time_t *)&statbufp->st_mtime);
9784         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9785         return 0;
9786       }
9787     }
9788
9789     /* Try for a directory name first.  If fspec contains a filename without
9790      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9791      * and sea:[wine.dark]water. exist, we prefer the directory here.
9792      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9793      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9794      * the file with null type, specify this by calling flex_stat() with
9795      * a '.' at the end of fspec.
9796      *
9797      * If we are in Posix filespec mode, accept the filename as is.
9798      */
9799 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9800   if (decc_posix_compliant_pathnames == 0) {
9801 #endif
9802     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9803       if (lstat_flag == 0)
9804         retval = stat(fileified,(stat_t *) statbufp);
9805       else
9806         retval = lstat(fileified,(stat_t *) statbufp);
9807       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9808         strcpy(namecache,fileified);
9809     }
9810     if (retval) {
9811       if (lstat_flag == 0)
9812         retval = stat(temp_fspec,(stat_t *) statbufp);
9813       else
9814         retval = lstat(temp_fspec,(stat_t *) statbufp);
9815     }
9816 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9817   } else {
9818     if (lstat_flag == 0)
9819       retval = stat(temp_fspec,(stat_t *) statbufp);
9820     else
9821       retval = lstat(temp_fspec,(stat_t *) statbufp);
9822   }
9823 #endif
9824     if (!retval) {
9825 #ifdef _USE_STD_STAT
9826       memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9827 #else
9828       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9829 #endif
9830 #ifndef _USE_STD_STAT
9831       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9832       statbufp->st_devnam[63] = 0;
9833       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9834 #else
9835     /* todo:
9836      * The device is only encoded so that Perl_cando can use it to
9837      * look up ACLS.  So rmsexpand it to the 255 character version
9838      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9839      * for long filenames and symbolic links first.  This also seems
9840      * to remove the need for a namecache that could be stale.
9841      */
9842 #endif
9843 #     ifdef RTL_USES_UTC
9844 #     ifdef VMSISH_TIME
9845       if (VMSISH_TIME) {
9846         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9847         statbufp->st_atime = _toloc(statbufp->st_atime);
9848         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9849       }
9850 #     endif
9851 #     else
9852 #     ifdef VMSISH_TIME
9853       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9854 #     else
9855       if (1) {
9856 #     endif
9857         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9858         statbufp->st_atime = _toutc(statbufp->st_atime);
9859         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9860       }
9861 #     endif
9862     }
9863     /* If we were successful, leave errno where we found it */
9864     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9865     return retval;
9866
9867 }  /* end of flex_stat_int() */
9868
9869
9870 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9871 int
9872 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9873 {
9874    return flex_stat_int(fspec, statbufp, 0);
9875 }
9876 /*}}}*/
9877
9878 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9879 int
9880 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9881 {
9882    return flex_stat_int(fspec, statbufp, 1);
9883 }
9884 /*}}}*/
9885
9886
9887 /*{{{char *my_getlogin()*/
9888 /* VMS cuserid == Unix getlogin, except calling sequence */
9889 char *
9890 my_getlogin(void)
9891 {
9892     static char user[L_cuserid];
9893     return cuserid(user);
9894 }
9895 /*}}}*/
9896
9897
9898 /*  rmscopy - copy a file using VMS RMS routines
9899  *
9900  *  Copies contents and attributes of spec_in to spec_out, except owner
9901  *  and protection information.  Name and type of spec_in are used as
9902  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9903  *  should try to propagate timestamps from the input file to the output file.
9904  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9905  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9906  *  propagated to the output file at creation iff the output file specification
9907  *  did not contain an explicit name or type, and the revision date is always
9908  *  updated at the end of the copy operation.  If it is greater than 0, then
9909  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9910  *  other than the revision date should be propagated, and bit 1 indicates
9911  *  that the revision date should be propagated.
9912  *
9913  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9914  *
9915  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9916  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9917  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9918  * as part of the Perl standard distribution under the terms of the
9919  * GNU General Public License or the Perl Artistic License.  Copies
9920  * of each may be found in the Perl standard distribution.
9921  */ /* FIXME */
9922 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9923 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9924 int
9925 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9926 {
9927     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9928          rsa[NAM$C_MAXRSS], ubf[32256];
9929     unsigned long int i, sts, sts2;
9930     struct FAB fab_in, fab_out;
9931     struct RAB rab_in, rab_out;
9932     struct NAM nam;
9933     struct XABDAT xabdat;
9934     struct XABFHC xabfhc;
9935     struct XABRDT xabrdt;
9936     struct XABSUM xabsum;
9937
9938     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9939         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9940       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9941       return 0;
9942     }
9943
9944     fab_in = cc$rms_fab;
9945     fab_in.fab$l_fna = vmsin;
9946     fab_in.fab$b_fns = strlen(vmsin);
9947     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9948     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9949     fab_in.fab$l_fop = FAB$M_SQO;
9950     fab_in.fab$l_nam =  &nam;
9951     fab_in.fab$l_xab = (void *) &xabdat;
9952
9953     nam = cc$rms_nam;
9954     nam.nam$l_rsa = rsa;
9955     nam.nam$b_rss = sizeof(rsa);
9956     nam.nam$l_esa = esa;
9957     nam.nam$b_ess = sizeof (esa);
9958     nam.nam$b_esl = nam.nam$b_rsl = 0;
9959 #ifdef NAM$M_NO_SHORT_UPCASE
9960     if (decc_efs_case_preserve)
9961         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9962 #endif
9963
9964     xabdat = cc$rms_xabdat;        /* To get creation date */
9965     xabdat.xab$l_nxt = (void *) &xabfhc;
9966
9967     xabfhc = cc$rms_xabfhc;        /* To get record length */
9968     xabfhc.xab$l_nxt = (void *) &xabsum;
9969
9970     xabsum = cc$rms_xabsum;        /* To get key and area information */
9971
9972     if (!((sts = sys$open(&fab_in)) & 1)) {
9973       set_vaxc_errno(sts);
9974       switch (sts) {
9975         case RMS$_FNF: case RMS$_DNF:
9976           set_errno(ENOENT); break;
9977         case RMS$_DIR:
9978           set_errno(ENOTDIR); break;
9979         case RMS$_DEV:
9980           set_errno(ENODEV); break;
9981         case RMS$_SYN:
9982           set_errno(EINVAL); break;
9983         case RMS$_PRV:
9984           set_errno(EACCES); break;
9985         default:
9986           set_errno(EVMSERR);
9987       }
9988       return 0;
9989     }
9990
9991     fab_out = fab_in;
9992     fab_out.fab$w_ifi = 0;
9993     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9994     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9995     fab_out.fab$l_fop = FAB$M_SQO;
9996     fab_out.fab$l_fna = vmsout;
9997     fab_out.fab$b_fns = strlen(vmsout);
9998     fab_out.fab$l_dna = nam.nam$l_name;
9999     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10000
10001     if (preserve_dates == 0) {  /* Act like DCL COPY */
10002       nam.nam$b_nop |= NAM$M_SYNCHK;
10003       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10004       if (!((sts = sys$parse(&fab_out)) & 1)) {
10005         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10006         set_vaxc_errno(sts);
10007         return 0;
10008       }
10009       fab_out.fab$l_xab = (void *) &xabdat;
10010       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10011     }
10012     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10013     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10014       preserve_dates =0;      /* bitmask from this point forward   */
10015
10016     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10017     if (!((sts = sys$create(&fab_out)) & 1)) {
10018       set_vaxc_errno(sts);
10019       switch (sts) {
10020         case RMS$_DNF:
10021           set_errno(ENOENT); break;
10022         case RMS$_DIR:
10023           set_errno(ENOTDIR); break;
10024         case RMS$_DEV:
10025           set_errno(ENODEV); break;
10026         case RMS$_SYN:
10027           set_errno(EINVAL); break;
10028         case RMS$_PRV:
10029           set_errno(EACCES); break;
10030         default:
10031           set_errno(EVMSERR);
10032       }
10033       return 0;
10034     }
10035     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10036     if (preserve_dates & 2) {
10037       /* sys$close() will process xabrdt, not xabdat */
10038       xabrdt = cc$rms_xabrdt;
10039 #ifndef __GNUC__
10040       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10041 #else
10042       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10043        * is unsigned long[2], while DECC & VAXC use a struct */
10044       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10045 #endif
10046       fab_out.fab$l_xab = (void *) &xabrdt;
10047     }
10048
10049     rab_in = cc$rms_rab;
10050     rab_in.rab$l_fab = &fab_in;
10051     rab_in.rab$l_rop = RAB$M_BIO;
10052     rab_in.rab$l_ubf = ubf;
10053     rab_in.rab$w_usz = sizeof ubf;
10054     if (!((sts = sys$connect(&rab_in)) & 1)) {
10055       sys$close(&fab_in); sys$close(&fab_out);
10056       set_errno(EVMSERR); set_vaxc_errno(sts);
10057       return 0;
10058     }
10059
10060     rab_out = cc$rms_rab;
10061     rab_out.rab$l_fab = &fab_out;
10062     rab_out.rab$l_rbf = ubf;
10063     if (!((sts = sys$connect(&rab_out)) & 1)) {
10064       sys$close(&fab_in); sys$close(&fab_out);
10065       set_errno(EVMSERR); set_vaxc_errno(sts);
10066       return 0;
10067     }
10068
10069     while ((sts = sys$read(&rab_in))) {  /* always true  */
10070       if (sts == RMS$_EOF) break;
10071       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10072       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10073         sys$close(&fab_in); sys$close(&fab_out);
10074         set_errno(EVMSERR); set_vaxc_errno(sts);
10075         return 0;
10076       }
10077     }
10078
10079     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10080     sys$close(&fab_in);  sys$close(&fab_out);
10081     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10082     if (!(sts & 1)) {
10083       set_errno(EVMSERR); set_vaxc_errno(sts);
10084       return 0;
10085     }
10086
10087     return 1;
10088
10089 }  /* end of rmscopy() */
10090 #else
10091 /* ODS-5 support version */
10092 int
10093 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10094 {
10095     char *vmsin, * vmsout, *esa, *esa_out,
10096          *rsa, *ubf;
10097     unsigned long int i, sts, sts2;
10098     struct FAB fab_in, fab_out;
10099     struct RAB rab_in, rab_out;
10100     struct NAML nam;
10101     struct NAML nam_out;
10102     struct XABDAT xabdat;
10103     struct XABFHC xabfhc;
10104     struct XABRDT xabrdt;
10105     struct XABSUM xabsum;
10106
10107     Newx(vmsin, VMS_MAXRSS, char);
10108     Newx(vmsout, VMS_MAXRSS, char);
10109     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10110         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10111       Safefree(vmsin);
10112       Safefree(vmsout);
10113       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10114       return 0;
10115     }
10116
10117     Newx(esa, VMS_MAXRSS, char);
10118     nam = cc$rms_naml;
10119     fab_in = cc$rms_fab;
10120     fab_in.fab$l_fna = (char *) -1;
10121     fab_in.fab$b_fns = 0;
10122     nam.naml$l_long_filename = vmsin;
10123     nam.naml$l_long_filename_size = strlen(vmsin);
10124     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10125     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10126     fab_in.fab$l_fop = FAB$M_SQO;
10127     fab_in.fab$l_naml =  &nam;
10128     fab_in.fab$l_xab = (void *) &xabdat;
10129
10130     Newx(rsa, VMS_MAXRSS, char);
10131     nam.naml$l_rsa = NULL;
10132     nam.naml$b_rss = 0;
10133     nam.naml$l_long_result = rsa;
10134     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10135     nam.naml$l_esa = NULL;
10136     nam.naml$b_ess = 0;
10137     nam.naml$l_long_expand = esa;
10138     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10139     nam.naml$b_esl = nam.naml$b_rsl = 0;
10140     nam.naml$l_long_expand_size = 0;
10141     nam.naml$l_long_result_size = 0;
10142 #ifdef NAM$M_NO_SHORT_UPCASE
10143     if (decc_efs_case_preserve)
10144         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10145 #endif
10146
10147     xabdat = cc$rms_xabdat;        /* To get creation date */
10148     xabdat.xab$l_nxt = (void *) &xabfhc;
10149
10150     xabfhc = cc$rms_xabfhc;        /* To get record length */
10151     xabfhc.xab$l_nxt = (void *) &xabsum;
10152
10153     xabsum = cc$rms_xabsum;        /* To get key and area information */
10154
10155     if (!((sts = sys$open(&fab_in)) & 1)) {
10156       Safefree(vmsin);
10157       Safefree(vmsout);
10158       Safefree(esa);
10159       Safefree(rsa);
10160       set_vaxc_errno(sts);
10161       switch (sts) {
10162         case RMS$_FNF: case RMS$_DNF:
10163           set_errno(ENOENT); break;
10164         case RMS$_DIR:
10165           set_errno(ENOTDIR); break;
10166         case RMS$_DEV:
10167           set_errno(ENODEV); break;
10168         case RMS$_SYN:
10169           set_errno(EINVAL); break;
10170         case RMS$_PRV:
10171           set_errno(EACCES); break;
10172         default:
10173           set_errno(EVMSERR);
10174       }
10175       return 0;
10176     }
10177
10178     nam_out = nam;
10179     fab_out = fab_in;
10180     fab_out.fab$w_ifi = 0;
10181     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10182     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10183     fab_out.fab$l_fop = FAB$M_SQO;
10184     fab_out.fab$l_naml = &nam_out;
10185     fab_out.fab$l_fna = (char *) -1;
10186     fab_out.fab$b_fns = 0;
10187     nam_out.naml$l_long_filename = vmsout;
10188     nam_out.naml$l_long_filename_size = strlen(vmsout);
10189     fab_out.fab$l_dna = (char *) -1;
10190     fab_out.fab$b_dns = 0;
10191     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10192     nam_out.naml$l_long_defname_size =
10193         nam.naml$l_long_name ?
10194            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10195
10196     Newx(esa_out, VMS_MAXRSS, char);
10197     nam_out.naml$l_rsa = NULL;
10198     nam_out.naml$b_rss = 0;
10199     nam_out.naml$l_long_result = NULL;
10200     nam_out.naml$l_long_result_alloc = 0;
10201     nam_out.naml$l_esa = NULL;
10202     nam_out.naml$b_ess = 0;
10203     nam_out.naml$l_long_expand = esa_out;
10204     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10205
10206     if (preserve_dates == 0) {  /* Act like DCL COPY */
10207       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10208       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10209       if (!((sts = sys$parse(&fab_out)) & 1)) {
10210         Safefree(vmsin);
10211         Safefree(vmsout);
10212         Safefree(esa);
10213         Safefree(rsa);
10214         Safefree(esa_out);
10215         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10216         set_vaxc_errno(sts);
10217         return 0;
10218       }
10219       fab_out.fab$l_xab = (void *) &xabdat;
10220       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10221     }
10222     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10223       preserve_dates =0;      /* bitmask from this point forward   */
10224
10225     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10226     if (!((sts = sys$create(&fab_out)) & 1)) {
10227       Safefree(vmsin);
10228       Safefree(vmsout);
10229       Safefree(esa);
10230       Safefree(rsa);
10231       Safefree(esa_out);
10232       set_vaxc_errno(sts);
10233       switch (sts) {
10234         case RMS$_DNF:
10235           set_errno(ENOENT); break;
10236         case RMS$_DIR:
10237           set_errno(ENOTDIR); break;
10238         case RMS$_DEV:
10239           set_errno(ENODEV); break;
10240         case RMS$_SYN:
10241           set_errno(EINVAL); break;
10242         case RMS$_PRV:
10243           set_errno(EACCES); break;
10244         default:
10245           set_errno(EVMSERR);
10246       }
10247       return 0;
10248     }
10249     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10250     if (preserve_dates & 2) {
10251       /* sys$close() will process xabrdt, not xabdat */
10252       xabrdt = cc$rms_xabrdt;
10253 #ifndef __GNUC__
10254       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10255 #else
10256       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10257        * is unsigned long[2], while DECC & VAXC use a struct */
10258       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10259 #endif
10260       fab_out.fab$l_xab = (void *) &xabrdt;
10261     }
10262
10263     Newx(ubf, 32256, char);
10264     rab_in = cc$rms_rab;
10265     rab_in.rab$l_fab = &fab_in;
10266     rab_in.rab$l_rop = RAB$M_BIO;
10267     rab_in.rab$l_ubf = ubf;
10268     rab_in.rab$w_usz = 32256;
10269     if (!((sts = sys$connect(&rab_in)) & 1)) {
10270       sys$close(&fab_in); sys$close(&fab_out);
10271       Safefree(vmsin);
10272       Safefree(vmsout);
10273       Safefree(esa);
10274       Safefree(ubf);
10275       Safefree(rsa);
10276       Safefree(esa_out);
10277       set_errno(EVMSERR); set_vaxc_errno(sts);
10278       return 0;
10279     }
10280
10281     rab_out = cc$rms_rab;
10282     rab_out.rab$l_fab = &fab_out;
10283     rab_out.rab$l_rbf = ubf;
10284     if (!((sts = sys$connect(&rab_out)) & 1)) {
10285       sys$close(&fab_in); sys$close(&fab_out);
10286       Safefree(vmsin);
10287       Safefree(vmsout);
10288       Safefree(esa);
10289       Safefree(ubf);
10290       Safefree(rsa);
10291       Safefree(esa_out);
10292       set_errno(EVMSERR); set_vaxc_errno(sts);
10293       return 0;
10294     }
10295
10296     while ((sts = sys$read(&rab_in))) {  /* always true  */
10297       if (sts == RMS$_EOF) break;
10298       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10299       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10300         sys$close(&fab_in); sys$close(&fab_out);
10301         Safefree(vmsin);
10302         Safefree(vmsout);
10303         Safefree(esa);
10304         Safefree(ubf);
10305         Safefree(rsa);
10306         Safefree(esa_out);
10307         set_errno(EVMSERR); set_vaxc_errno(sts);
10308         return 0;
10309       }
10310     }
10311
10312
10313     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10314     sys$close(&fab_in);  sys$close(&fab_out);
10315     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10316     if (!(sts & 1)) {
10317       Safefree(vmsin);
10318       Safefree(vmsout);
10319       Safefree(esa);
10320       Safefree(ubf);
10321       Safefree(rsa);
10322       Safefree(esa_out);
10323       set_errno(EVMSERR); set_vaxc_errno(sts);
10324       return 0;
10325     }
10326
10327     Safefree(vmsin);
10328     Safefree(vmsout);
10329     Safefree(esa);
10330     Safefree(ubf);
10331     Safefree(rsa);
10332     Safefree(esa_out);
10333     return 1;
10334
10335 }  /* end of rmscopy() */
10336 #endif
10337 /*}}}*/
10338
10339
10340 /***  The following glue provides 'hooks' to make some of the routines
10341  * from this file available from Perl.  These routines are sufficiently
10342  * basic, and are required sufficiently early in the build process,
10343  * that's it's nice to have them available to miniperl as well as the
10344  * full Perl, so they're set up here instead of in an extension.  The
10345  * Perl code which handles importation of these names into a given
10346  * package lives in [.VMS]Filespec.pm in @INC.
10347  */
10348
10349 void
10350 rmsexpand_fromperl(pTHX_ CV *cv)
10351 {
10352   dXSARGS;
10353   char *fspec, *defspec = NULL, *rslt;
10354   STRLEN n_a;
10355
10356   if (!items || items > 2)
10357     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10358   fspec = SvPV(ST(0),n_a);
10359   if (!fspec || !*fspec) XSRETURN_UNDEF;
10360   if (items == 2) defspec = SvPV(ST(1),n_a);
10361
10362   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10363   ST(0) = sv_newmortal();
10364   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10365   XSRETURN(1);
10366 }
10367
10368 void
10369 vmsify_fromperl(pTHX_ CV *cv)
10370 {
10371   dXSARGS;
10372   char *vmsified;
10373   STRLEN n_a;
10374
10375   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10376   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10377   ST(0) = sv_newmortal();
10378   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10379   XSRETURN(1);
10380 }
10381
10382 void
10383 unixify_fromperl(pTHX_ CV *cv)
10384 {
10385   dXSARGS;
10386   char *unixified;
10387   STRLEN n_a;
10388
10389   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10390   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10391   ST(0) = sv_newmortal();
10392   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10393   XSRETURN(1);
10394 }
10395
10396 void
10397 fileify_fromperl(pTHX_ CV *cv)
10398 {
10399   dXSARGS;
10400   char *fileified;
10401   STRLEN n_a;
10402
10403   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10404   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10405   ST(0) = sv_newmortal();
10406   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10407   XSRETURN(1);
10408 }
10409
10410 void
10411 pathify_fromperl(pTHX_ CV *cv)
10412 {
10413   dXSARGS;
10414   char *pathified;
10415   STRLEN n_a;
10416
10417   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10418   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10419   ST(0) = sv_newmortal();
10420   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10421   XSRETURN(1);
10422 }
10423
10424 void
10425 vmspath_fromperl(pTHX_ CV *cv)
10426 {
10427   dXSARGS;
10428   char *vmspath;
10429   STRLEN n_a;
10430
10431   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10432   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10433   ST(0) = sv_newmortal();
10434   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10435   XSRETURN(1);
10436 }
10437
10438 void
10439 unixpath_fromperl(pTHX_ CV *cv)
10440 {
10441   dXSARGS;
10442   char *unixpath;
10443   STRLEN n_a;
10444
10445   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10446   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10447   ST(0) = sv_newmortal();
10448   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10449   XSRETURN(1);
10450 }
10451
10452 void
10453 candelete_fromperl(pTHX_ CV *cv)
10454 {
10455   dXSARGS;
10456   char fspec[NAM$C_MAXRSS+1], *fsp;
10457   SV *mysv;
10458   IO *io;
10459   STRLEN n_a;
10460
10461   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10462
10463   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10464   if (SvTYPE(mysv) == SVt_PVGV) {
10465     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10466       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10467       ST(0) = &PL_sv_no;
10468       XSRETURN(1);
10469     }
10470     fsp = fspec;
10471   }
10472   else {
10473     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10474       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10475       ST(0) = &PL_sv_no;
10476       XSRETURN(1);
10477     }
10478   }
10479
10480   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10481   XSRETURN(1);
10482 }
10483
10484 void
10485 rmscopy_fromperl(pTHX_ CV *cv)
10486 {
10487   dXSARGS;
10488   char *inspec, *outspec, *inp, *outp;
10489   int date_flag;
10490   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10491                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10492   unsigned long int sts;
10493   SV *mysv;
10494   IO *io;
10495   STRLEN n_a;
10496
10497   if (items < 2 || items > 3)
10498     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10499
10500   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10501   Newx(inspec, VMS_MAXRSS, char);
10502   if (SvTYPE(mysv) == SVt_PVGV) {
10503     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10504       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10505       ST(0) = &PL_sv_no;
10506       Safefree(inspec);
10507       XSRETURN(1);
10508     }
10509     inp = inspec;
10510   }
10511   else {
10512     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10513       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10514       ST(0) = &PL_sv_no;
10515       Safefree(inspec);
10516       XSRETURN(1);
10517     }
10518   }
10519   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10520   Newx(outspec, VMS_MAXRSS, char);
10521   if (SvTYPE(mysv) == SVt_PVGV) {
10522     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10523       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10524       ST(0) = &PL_sv_no;
10525       Safefree(inspec);
10526       Safefree(outspec);
10527       XSRETURN(1);
10528     }
10529     outp = outspec;
10530   }
10531   else {
10532     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10533       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10534       ST(0) = &PL_sv_no;
10535       Safefree(inspec);
10536       Safefree(outspec);
10537       XSRETURN(1);
10538     }
10539   }
10540   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10541
10542   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10543   Safefree(inspec);
10544   Safefree(outspec);
10545   XSRETURN(1);
10546 }
10547
10548 /* The mod2fname is limited to shorter filenames by design, so it should
10549  * not be modified to support longer EFS pathnames
10550  */
10551 void
10552 mod2fname(pTHX_ CV *cv)
10553 {
10554   dXSARGS;
10555   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10556        workbuff[NAM$C_MAXRSS*1 + 1];
10557   int total_namelen = 3, counter, num_entries;
10558   /* ODS-5 ups this, but we want to be consistent, so... */
10559   int max_name_len = 39;
10560   AV *in_array = (AV *)SvRV(ST(0));
10561
10562   num_entries = av_len(in_array);
10563
10564   /* All the names start with PL_. */
10565   strcpy(ultimate_name, "PL_");
10566
10567   /* Clean up our working buffer */
10568   Zero(work_name, sizeof(work_name), char);
10569
10570   /* Run through the entries and build up a working name */
10571   for(counter = 0; counter <= num_entries; counter++) {
10572     /* If it's not the first name then tack on a __ */
10573     if (counter) {
10574       strcat(work_name, "__");
10575     }
10576     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10577                            PL_na));
10578   }
10579
10580   /* Check to see if we actually have to bother...*/
10581   if (strlen(work_name) + 3 <= max_name_len) {
10582     strcat(ultimate_name, work_name);
10583   } else {
10584     /* It's too darned big, so we need to go strip. We use the same */
10585     /* algorithm as xsubpp does. First, strip out doubled __ */
10586     char *source, *dest, last;
10587     dest = workbuff;
10588     last = 0;
10589     for (source = work_name; *source; source++) {
10590       if (last == *source && last == '_') {
10591         continue;
10592       }
10593       *dest++ = *source;
10594       last = *source;
10595     }
10596     /* Go put it back */
10597     strcpy(work_name, workbuff);
10598     /* Is it still too big? */
10599     if (strlen(work_name) + 3 > max_name_len) {
10600       /* Strip duplicate letters */
10601       last = 0;
10602       dest = workbuff;
10603       for (source = work_name; *source; source++) {
10604         if (last == toupper(*source)) {
10605         continue;
10606         }
10607         *dest++ = *source;
10608         last = toupper(*source);
10609       }
10610       strcpy(work_name, workbuff);
10611     }
10612
10613     /* Is it *still* too big? */
10614     if (strlen(work_name) + 3 > max_name_len) {
10615       /* Too bad, we truncate */
10616       work_name[max_name_len - 2] = 0;
10617     }
10618     strcat(ultimate_name, work_name);
10619   }
10620
10621   /* Okay, return it */
10622   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10623   XSRETURN(1);
10624 }
10625
10626 void
10627 hushexit_fromperl(pTHX_ CV *cv)
10628 {
10629     dXSARGS;
10630
10631     if (items > 0) {
10632         VMSISH_HUSHED = SvTRUE(ST(0));
10633     }
10634     ST(0) = boolSV(VMSISH_HUSHED);
10635     XSRETURN(1);
10636 }
10637
10638 #ifdef HAS_SYMLINK
10639 static char *
10640 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10641
10642 void
10643 vms_realpath_fromperl(pTHX_ CV *cv)
10644 {
10645   dXSARGS;
10646   char *fspec, *rslt_spec, *rslt;
10647   STRLEN n_a;
10648
10649   if (!items || items != 1)
10650     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10651
10652   fspec = SvPV(ST(0),n_a);
10653   if (!fspec || !*fspec) XSRETURN_UNDEF;
10654
10655   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10656   rslt = do_vms_realpath(fspec, rslt_spec);
10657   ST(0) = sv_newmortal();
10658   if (rslt != NULL)
10659     sv_usepvn(ST(0),rslt,strlen(rslt));
10660   else
10661     Safefree(rslt_spec);
10662   XSRETURN(1);
10663 }
10664 #endif
10665
10666 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10667 int do_vms_case_tolerant(void);
10668
10669 void
10670 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10671 {
10672   dXSARGS;
10673   ST(0) = boolSV(do_vms_case_tolerant());
10674   XSRETURN(1);
10675 }
10676 #endif
10677
10678 void
10679 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10680                           struct interp_intern *dst)
10681 {
10682     memcpy(dst,src,sizeof(struct interp_intern));
10683 }
10684
10685 void
10686 Perl_sys_intern_clear(pTHX)
10687 {
10688 }
10689
10690 void
10691 Perl_sys_intern_init(pTHX)
10692 {
10693     unsigned int ix = RAND_MAX;
10694     double x;
10695
10696     VMSISH_HUSHED = 0;
10697
10698     /* fix me later to track running under GNV */
10699     /* this allows some limited testing */
10700     MY_POSIX_EXIT = decc_filename_unix_report;
10701
10702     x = (float)ix;
10703     MY_INV_RAND_MAX = 1./x;
10704 }
10705
10706 void
10707 init_os_extras(void)
10708 {
10709   dTHX;
10710   char* file = __FILE__;
10711   char temp_buff[512];
10712   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10713     no_translate_barewords = TRUE;
10714   } else {
10715     no_translate_barewords = FALSE;
10716   }
10717
10718   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10719   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10720   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10721   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10722   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10723   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10724   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10725   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10726   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10727   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10728   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10729 #ifdef HAS_SYMLINK
10730   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10731 #endif
10732 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10733   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10734 #endif
10735
10736   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10737
10738   return;
10739 }
10740
10741 #ifdef HAS_SYMLINK
10742
10743 #if __CRTL_VER == 80200000
10744 /* This missed getting in to the DECC SDK for 8.2 */
10745 char *realpath(const char *file_name, char * resolved_name, ...);
10746 #endif
10747
10748 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10749 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10750  * The perl fallback routine to provide realpath() is not as efficient
10751  * on OpenVMS.
10752  */
10753 static char *
10754 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10755 {
10756     return realpath(filespec, outbuf);
10757 }
10758
10759 /*}}}*/
10760 /* External entry points */
10761 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10762 { return do_vms_realpath(filespec, outbuf); }
10763 #else
10764 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10765 { return NULL; }
10766 #endif
10767
10768
10769 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10770 /* case_tolerant */
10771
10772 /*{{{int do_vms_case_tolerant(void)*/
10773 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10774  * controlled by a process setting.
10775  */
10776 int do_vms_case_tolerant(void)
10777 {
10778     return vms_process_case_tolerant;
10779 }
10780 /*}}}*/
10781 /* External entry points */
10782 int Perl_vms_case_tolerant(void)
10783 { return do_vms_case_tolerant(); }
10784 #else
10785 int Perl_vms_case_tolerant(void)
10786 { return vms_process_case_tolerant; }
10787 #endif
10788
10789
10790  /* Start of DECC RTL Feature handling */
10791
10792 static int sys_trnlnm
10793    (const char * logname,
10794     char * value,
10795     int value_len)
10796 {
10797     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10798     const unsigned long attr = LNM$M_CASE_BLIND;
10799     struct dsc$descriptor_s name_dsc;
10800     int status;
10801     unsigned short result;
10802     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10803                                 {0, 0, 0, 0}};
10804
10805     name_dsc.dsc$w_length = strlen(logname);
10806     name_dsc.dsc$a_pointer = (char *)logname;
10807     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10808     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10809
10810     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10811
10812     if ($VMS_STATUS_SUCCESS(status)) {
10813
10814          /* Null terminate and return the string */
10815         /*--------------------------------------*/
10816         value[result] = 0;
10817     }
10818
10819     return status;
10820 }
10821
10822 static int sys_crelnm
10823    (const char * logname,
10824     const char * value)
10825 {
10826     int ret_val;
10827     const char * proc_table = "LNM$PROCESS_TABLE";
10828     struct dsc$descriptor_s proc_table_dsc;
10829     struct dsc$descriptor_s logname_dsc;
10830     struct itmlst_3 item_list[2];
10831
10832     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10833     proc_table_dsc.dsc$w_length = strlen(proc_table);
10834     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10835     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10836
10837     logname_dsc.dsc$a_pointer = (char *) logname;
10838     logname_dsc.dsc$w_length = strlen(logname);
10839     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10840     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10841
10842     item_list[0].buflen = strlen(value);
10843     item_list[0].itmcode = LNM$_STRING;
10844     item_list[0].bufadr = (char *)value;
10845     item_list[0].retlen = NULL;
10846
10847     item_list[1].buflen = 0;
10848     item_list[1].itmcode = 0;
10849
10850     ret_val = sys$crelnm
10851                        (NULL,
10852                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10853                         (const struct dsc$descriptor_s *)&logname_dsc,
10854                         NULL,
10855                         (const struct item_list_3 *) item_list);
10856
10857     return ret_val;
10858 }
10859
10860
10861 /* C RTL Feature settings */
10862
10863 static int set_features
10864    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10865     int (* cli_routine)(void),  /* Not documented */
10866     void *image_info)           /* Not documented */
10867 {
10868     int status;
10869     int s;
10870     int dflt;
10871     char* str;
10872     char val_str[10];
10873     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10874     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10875     unsigned long case_perm;
10876     unsigned long case_image;
10877
10878     /* hacks to see if known bugs are still present for testing */
10879
10880     /* Readdir is returning filenames in VMS syntax always */
10881     decc_bug_readdir_efs1 = 1;
10882     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10883     if ($VMS_STATUS_SUCCESS(status)) {
10884        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10885          decc_bug_readdir_efs1 = 1;
10886        else
10887          decc_bug_readdir_efs1 = 0;
10888     }
10889
10890     /* PCP mode requires creating /dev/null special device file */
10891     decc_bug_devnull = 0;
10892     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10893     if ($VMS_STATUS_SUCCESS(status)) {
10894        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10895           decc_bug_devnull = 1;
10896     }
10897
10898     /* fgetname returning a VMS name in UNIX mode */
10899     decc_bug_fgetname = 1;
10900     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10901     if ($VMS_STATUS_SUCCESS(status)) {
10902       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10903         decc_bug_fgetname = 1;
10904       else
10905         decc_bug_fgetname = 0;
10906     }
10907
10908     /* UNIX directory names with no paths are broken in a lot of places */
10909     decc_dir_barename = 1;
10910     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10911     if ($VMS_STATUS_SUCCESS(status)) {
10912       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10913         decc_dir_barename = 1;
10914       else
10915         decc_dir_barename = 0;
10916     }
10917
10918 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10919     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10920     if (s >= 0) {
10921         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10922         if (decc_disable_to_vms_logname_translation < 0)
10923             decc_disable_to_vms_logname_translation = 0;
10924     }
10925
10926     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10927     if (s >= 0) {
10928         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10929         if (decc_efs_case_preserve < 0)
10930             decc_efs_case_preserve = 0;
10931     }
10932
10933     s = decc$feature_get_index("DECC$EFS_CHARSET");
10934     if (s >= 0) {
10935         decc_efs_charset = decc$feature_get_value(s, 1);
10936         if (decc_efs_charset < 0)
10937             decc_efs_charset = 0;
10938     }
10939
10940     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10941     if (s >= 0) {
10942         decc_filename_unix_report = decc$feature_get_value(s, 1);
10943         if (decc_filename_unix_report > 0)
10944             decc_filename_unix_report = 1;
10945         else
10946             decc_filename_unix_report = 0;
10947     }
10948
10949     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10950     if (s >= 0) {
10951         decc_filename_unix_only = decc$feature_get_value(s, 1);
10952         if (decc_filename_unix_only > 0) {
10953             decc_filename_unix_only = 1;
10954         }
10955         else {
10956             decc_filename_unix_only = 0;
10957         }
10958     }
10959
10960     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10961     if (s >= 0) {
10962         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10963         if (decc_filename_unix_no_version < 0)
10964             decc_filename_unix_no_version = 0;
10965     }
10966
10967     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10968     if (s >= 0) {
10969         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10970         if (decc_readdir_dropdotnotype < 0)
10971             decc_readdir_dropdotnotype = 0;
10972     }
10973
10974     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10975     if ($VMS_STATUS_SUCCESS(status)) {
10976         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10977         if (s >= 0) {
10978             dflt = decc$feature_get_value(s, 4);
10979             if (dflt > 0) {
10980                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10981                 if (decc_disable_posix_root <= 0) {
10982                     decc$feature_set_value(s, 1, 1);
10983                     decc_disable_posix_root = 1;
10984                 }
10985             }
10986             else {
10987                 /* Traditionally Perl assumes this is off */
10988                 decc_disable_posix_root = 1;
10989                 decc$feature_set_value(s, 1, 1);
10990             }
10991         }
10992     }
10993
10994 #if __CRTL_VER >= 80200000
10995     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10996     if (s >= 0) {
10997         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10998         if (decc_posix_compliant_pathnames < 0)
10999             decc_posix_compliant_pathnames = 0;
11000         if (decc_posix_compliant_pathnames > 4)
11001             decc_posix_compliant_pathnames = 0;
11002     }
11003
11004 #endif
11005 #else
11006     status = sys_trnlnm
11007         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11008     if ($VMS_STATUS_SUCCESS(status)) {
11009         val_str[0] = _toupper(val_str[0]);
11010         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11011            decc_disable_to_vms_logname_translation = 1;
11012         }
11013     }
11014
11015 #ifndef __VAX
11016     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11017     if ($VMS_STATUS_SUCCESS(status)) {
11018         val_str[0] = _toupper(val_str[0]);
11019         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11020            decc_efs_case_preserve = 1;
11021         }
11022     }
11023 #endif
11024
11025     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11026     if ($VMS_STATUS_SUCCESS(status)) {
11027         val_str[0] = _toupper(val_str[0]);
11028         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11029            decc_filename_unix_report = 1;
11030         }
11031     }
11032     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11033     if ($VMS_STATUS_SUCCESS(status)) {
11034         val_str[0] = _toupper(val_str[0]);
11035         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11036            decc_filename_unix_only = 1;
11037            decc_filename_unix_report = 1;
11038         }
11039     }
11040     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11041     if ($VMS_STATUS_SUCCESS(status)) {
11042         val_str[0] = _toupper(val_str[0]);
11043         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11044            decc_filename_unix_no_version = 1;
11045         }
11046     }
11047     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11048     if ($VMS_STATUS_SUCCESS(status)) {
11049         val_str[0] = _toupper(val_str[0]);
11050         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11051            decc_readdir_dropdotnotype = 1;
11052         }
11053     }
11054 #endif
11055
11056 #ifndef __VAX
11057
11058      /* Report true case tolerance */
11059     /*----------------------------*/
11060     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11061     if (!$VMS_STATUS_SUCCESS(status))
11062         case_perm = PPROP$K_CASE_BLIND;
11063     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11064     if (!$VMS_STATUS_SUCCESS(status))
11065         case_image = PPROP$K_CASE_BLIND;
11066     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11067         (case_image == PPROP$K_CASE_SENSITIVE))
11068         vms_process_case_tolerant = 0;
11069
11070 #endif
11071
11072
11073     /* CRTL can be initialized past this point, but not before. */
11074 /*    DECC$CRTL_INIT(); */
11075
11076     return SS$_NORMAL;
11077 }
11078
11079 #ifdef __DECC
11080 /* DECC dependent attributes */
11081 #if __DECC_VER < 60560002
11082 #define relative
11083 #define not_executable
11084 #else
11085 #define relative ,rel
11086 #define not_executable ,noexe
11087 #endif
11088 #pragma nostandard
11089 #pragma extern_model save
11090 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11091 #endif
11092         const __align (LONGWORD) int spare[8] = {0};
11093 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11094 /*                        NOWRT, LONG */
11095 #ifdef __DECC
11096 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11097         nowrt,noshr relative not_executable
11098 #endif
11099 const long vms_cc_features = (const long)set_features;
11100
11101 /*
11102 ** Force a reference to LIB$INITIALIZE to ensure it
11103 ** exists in the image.
11104 */
11105 int lib$initialize(void);
11106 #ifdef __DECC
11107 #pragma extern_model strict_refdef
11108 #endif
11109     int lib_init_ref = (int) lib$initialize;
11110
11111 #ifdef __DECC
11112 #pragma extern_model restore
11113 #pragma standard
11114 #endif
11115
11116 /*  End of vms.c */