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 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9264 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9265 {
9266     return utime(file, utimes);
9267 }
9268 #else
9269 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9270 {
9271   register int i;
9272   int sts;
9273   long int bintime[2], len = 2, lowbit, unixtime,
9274            secscale = 10000000; /* seconds --> 100 ns intervals */
9275   unsigned long int chan, iosb[2], retsts;
9276   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9277   struct FAB myfab = cc$rms_fab;
9278   struct NAM mynam = cc$rms_nam;
9279 #if defined (__DECC) && defined (__VAX)
9280   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9281    * at least through VMS V6.1, which causes a type-conversion warning.
9282    */
9283 #  pragma message save
9284 #  pragma message disable cvtdiftypes
9285 #endif
9286   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9287   struct fibdef myfib;
9288 #if defined (__DECC) && defined (__VAX)
9289   /* This should be right after the declaration of myatr, but due
9290    * to a bug in VAX DEC C, this takes effect a statement early.
9291    */
9292 #  pragma message restore
9293 #endif
9294   /* cast ok for read only parameter */
9295   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9296                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9297                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9298
9299   if (file == NULL || *file == '\0') {
9300     set_errno(ENOENT);
9301     set_vaxc_errno(LIB$_INVARG);
9302     return -1;
9303   }
9304   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9305
9306   if (utimes != NULL) {
9307     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9308      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9309      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9310      * as input, we force the sign bit to be clear by shifting unixtime right
9311      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9312      */
9313     lowbit = (utimes->modtime & 1) ? secscale : 0;
9314     unixtime = (long int) utimes->modtime;
9315 #   ifdef VMSISH_TIME
9316     /* If input was UTC; convert to local for sys svc */
9317     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9318 #   endif
9319     unixtime >>= 1;  secscale <<= 1;
9320     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9321     if (!(retsts & 1)) {
9322       set_errno(EVMSERR);
9323       set_vaxc_errno(retsts);
9324       return -1;
9325     }
9326     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9327     if (!(retsts & 1)) {
9328       set_errno(EVMSERR);
9329       set_vaxc_errno(retsts);
9330       return -1;
9331     }
9332   }
9333   else {
9334     /* Just get the current time in VMS format directly */
9335     retsts = sys$gettim(bintime);
9336     if (!(retsts & 1)) {
9337       set_errno(EVMSERR);
9338       set_vaxc_errno(retsts);
9339       return -1;
9340     }
9341   }
9342
9343   myfab.fab$l_fna = vmsspec;
9344   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9345   myfab.fab$l_nam = &mynam;
9346   mynam.nam$l_esa = esa;
9347   mynam.nam$b_ess = (unsigned char) sizeof esa;
9348   mynam.nam$l_rsa = rsa;
9349   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9350   if (decc_efs_case_preserve)
9351       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9352
9353   /* Look for the file to be affected, letting RMS parse the file
9354    * specification for us as well.  I have set errno using only
9355    * values documented in the utime() man page for VMS POSIX.
9356    */
9357   retsts = sys$parse(&myfab,0,0);
9358   if (!(retsts & 1)) {
9359     set_vaxc_errno(retsts);
9360     if      (retsts == RMS$_PRV) set_errno(EACCES);
9361     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9362     else                         set_errno(EVMSERR);
9363     return -1;
9364   }
9365   retsts = sys$search(&myfab,0,0);
9366   if (!(retsts & 1)) {
9367     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9368     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9369     set_vaxc_errno(retsts);
9370     if      (retsts == RMS$_PRV) set_errno(EACCES);
9371     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9372     else                         set_errno(EVMSERR);
9373     return -1;
9374   }
9375
9376   devdsc.dsc$w_length = mynam.nam$b_dev;
9377   /* cast ok for read only parameter */
9378   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9379
9380   retsts = sys$assign(&devdsc,&chan,0,0);
9381   if (!(retsts & 1)) {
9382     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9383     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9384     set_vaxc_errno(retsts);
9385     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9386     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9387     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9388     else                               set_errno(EVMSERR);
9389     return -1;
9390   }
9391
9392   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9393   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9394
9395   memset((void *) &myfib, 0, sizeof myfib);
9396 #if defined(__DECC) || defined(__DECCXX)
9397   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9398   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9399   /* This prevents the revision time of the file being reset to the current
9400    * time as a result of our IO$_MODIFY $QIO. */
9401   myfib.fib$l_acctl = FIB$M_NORECORD;
9402 #else
9403   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9404   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9405   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9406 #endif
9407   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9408   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9409   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9410   _ckvmssts(sys$dassgn(chan));
9411   if (retsts & 1) retsts = iosb[0];
9412   if (!(retsts & 1)) {
9413     set_vaxc_errno(retsts);
9414     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9415     else                      set_errno(EVMSERR);
9416     return -1;
9417   }
9418
9419   return 0;
9420 }  /* end of my_utime() */
9421 #endif
9422 /*}}}*/
9423
9424 /*
9425  * flex_stat, flex_lstat, flex_fstat
9426  * basic stat, but gets it right when asked to stat
9427  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9428  */
9429
9430 #ifndef _USE_STD_STAT
9431 /* encode_dev packs a VMS device name string into an integer to allow
9432  * simple comparisons. This can be used, for example, to check whether two
9433  * files are located on the same device, by comparing their encoded device
9434  * names. Even a string comparison would not do, because stat() reuses the
9435  * device name buffer for each call; so without encode_dev, it would be
9436  * necessary to save the buffer and use strcmp (this would mean a number of
9437  * changes to the standard Perl code, to say nothing of what a Perl script
9438  * would have to do.
9439  *
9440  * The device lock id, if it exists, should be unique (unless perhaps compared
9441  * with lock ids transferred from other nodes). We have a lock id if the disk is
9442  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9443  * device names. Thus we use the lock id in preference, and only if that isn't
9444  * available, do we try to pack the device name into an integer (flagged by
9445  * the sign bit (LOCKID_MASK) being set).
9446  *
9447  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9448  * name and its encoded form, but it seems very unlikely that we will find
9449  * two files on different disks that share the same encoded device names,
9450  * and even more remote that they will share the same file id (if the test
9451  * is to check for the same file).
9452  *
9453  * A better method might be to use sys$device_scan on the first call, and to
9454  * search for the device, returning an index into the cached array.
9455  * The number returned would be more intelligable.
9456  * This is probably not worth it, and anyway would take quite a bit longer
9457  * on the first call.
9458  */
9459 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9460 static mydev_t encode_dev (pTHX_ const char *dev)
9461 {
9462   int i;
9463   unsigned long int f;
9464   mydev_t enc;
9465   char c;
9466   const char *q;
9467
9468   if (!dev || !dev[0]) return 0;
9469
9470 #if LOCKID_MASK
9471   {
9472     struct dsc$descriptor_s dev_desc;
9473     unsigned long int status, lockid, item = DVI$_LOCKID;
9474
9475     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9476        can try that first. */
9477     dev_desc.dsc$w_length =  strlen (dev);
9478     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9479     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9480     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9481     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9482     if (lockid) return (lockid & ~LOCKID_MASK);
9483   }
9484 #endif
9485
9486   /* Otherwise we try to encode the device name */
9487   enc = 0;
9488   f = 1;
9489   i = 0;
9490   for (q = dev + strlen(dev); q--; q >= dev) {
9491     if (isdigit (*q))
9492       c= (*q) - '0';
9493     else if (isalpha (toupper (*q)))
9494       c= toupper (*q) - 'A' + (char)10;
9495     else
9496       continue; /* Skip '$'s */
9497     i++;
9498     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9499     if (i>1) f *= 36;
9500     enc += f * (unsigned long int) c;
9501   }
9502   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9503
9504 }  /* end of encode_dev() */
9505 #endif
9506
9507 static char namecache[NAM$C_MAXRSS+1];
9508
9509 static int
9510 is_null_device(name)
9511     const char *name;
9512 {
9513   if (decc_bug_devnull != 0) {
9514     if (strcmp("/dev/null", name) == 0) /* temp hack */
9515       return 1;
9516   }
9517     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9518        The underscore prefix, controller letter, and unit number are
9519        independently optional; for our purposes, the colon punctuation
9520        is not.  The colon can be trailed by optional directory and/or
9521        filename, but two consecutive colons indicates a nodename rather
9522        than a device.  [pr]  */
9523   if (*name == '_') ++name;
9524   if (tolower(*name++) != 'n') return 0;
9525   if (tolower(*name++) != 'l') return 0;
9526   if (tolower(*name) == 'a') ++name;
9527   if (*name == '0') ++name;
9528   return (*name++ == ':') && (*name != ':');
9529 }
9530
9531 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9532 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9533  * subset of the applicable information.
9534  */
9535 bool
9536 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9537 {
9538   char fname_phdev[NAM$C_MAXRSS+1];
9539 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9540   /* Namecache not workable with symbolic links, as symbolic links do
9541    *  not have extensions and directories do in VMS mode.  So in order
9542    *  to test this, the did and ino_t must be used.
9543    *
9544    * Fix-me - Hide the information in the new stat structure
9545    *          Get rid of the namecache.
9546    */
9547   if (decc_posix_compliant_pathnames == 0)
9548 #endif
9549       if (statbufp == &PL_statcache)
9550           return cando_by_name(bit,effective,namecache);
9551   {
9552     char fname[NAM$C_MAXRSS+1];
9553     unsigned long int retsts;
9554     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9555                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9556
9557     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9558        device name on successive calls */
9559     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9560     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9561     namdsc.dsc$a_pointer = fname;
9562     namdsc.dsc$w_length = sizeof fname - 1;
9563
9564     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9565                              &namdsc,&namdsc.dsc$w_length,0,0);
9566     if (retsts & 1) {
9567       fname[namdsc.dsc$w_length] = '\0';
9568 /*
9569  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9570  * but if someone has redefined that logical, Perl gets very lost.  Since
9571  * we have the physical device name from the stat buffer, just paste it on.
9572  */
9573       strcpy( fname_phdev, statbufp->st_devnam );
9574       strcat( fname_phdev, strrchr(fname, ':') );
9575
9576       return cando_by_name(bit,effective,fname_phdev);
9577     }
9578     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9579       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9580       return FALSE;
9581     }
9582     _ckvmssts(retsts);
9583     return FALSE;  /* Should never get to here */
9584   }
9585 }  /* end of cando() */
9586 /*}}}*/
9587
9588
9589 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9590 I32
9591 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9592 {
9593   static char usrname[L_cuserid];
9594   static struct dsc$descriptor_s usrdsc =
9595          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9596   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9597   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9598   unsigned short int retlen, trnlnm_iter_count;
9599   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9600   union prvdef curprv;
9601   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9602          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9603   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9604          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9605          {0,0,0,0}};
9606   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9607          {0,0,0,0}};
9608   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9609
9610   if (!fname || !*fname) return FALSE;
9611   /* Make sure we expand logical names, since sys$check_access doesn't */
9612   if (!strpbrk(fname,"/]>:")) {
9613     strcpy(fileified,fname);
9614     trnlnm_iter_count = 0;
9615     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9616         trnlnm_iter_count++;
9617         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9618     }
9619     fname = fileified;
9620   }
9621   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9622   retlen = namdsc.dsc$w_length = strlen(vmsname);
9623   namdsc.dsc$a_pointer = vmsname;
9624   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9625       vmsname[retlen-1] == ':') {
9626     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9627     namdsc.dsc$w_length = strlen(fileified);
9628     namdsc.dsc$a_pointer = fileified;
9629   }
9630
9631   switch (bit) {
9632     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9633       access = ARM$M_EXECUTE; break;
9634     case S_IRUSR: case S_IRGRP: case S_IROTH:
9635       access = ARM$M_READ; break;
9636     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9637       access = ARM$M_WRITE; break;
9638     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9639       access = ARM$M_DELETE; break;
9640     default:
9641       return FALSE;
9642   }
9643
9644   /* Before we call $check_access, create a user profile with the current
9645    * process privs since otherwise it just uses the default privs from the
9646    * UAF and might give false positives or negatives.  This only works on
9647    * VMS versions v6.0 and later since that's when sys$create_user_profile
9648    * became available.
9649    */
9650
9651   /* get current process privs and username */
9652   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9653   _ckvmssts(iosb[0]);
9654
9655 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9656
9657   /* find out the space required for the profile */
9658   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9659                                     &usrprodsc.dsc$w_length,0));
9660
9661   /* allocate space for the profile and get it filled in */
9662   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9663   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9664                                     &usrprodsc.dsc$w_length,0));
9665
9666   /* use the profile to check access to the file; free profile & analyze results */
9667   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9668   Safefree(usrprodsc.dsc$a_pointer);
9669   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9670
9671 #else
9672
9673   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9674
9675 #endif
9676
9677   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9678       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9679       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9680     set_vaxc_errno(retsts);
9681     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9682     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9683     else set_errno(ENOENT);
9684     return FALSE;
9685   }
9686   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9687     return TRUE;
9688   }
9689   _ckvmssts(retsts);
9690
9691   return FALSE;  /* Should never get here */
9692
9693 }  /* end of cando_by_name() */
9694 /*}}}*/
9695
9696
9697 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9698 int
9699 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9700 {
9701   if (!fstat(fd,(stat_t *) statbufp)) {
9702     if (statbufp == (Stat_t *) &PL_statcache) {
9703     char *cptr;
9704
9705         /* Save name for cando by name in VMS format */
9706         cptr = getname(fd, namecache, 1);
9707
9708         /* This should not happen, but just in case */
9709         if (cptr == NULL)
9710            namecache[0] = '\0';
9711     }
9712 #ifdef _USE_STD_STAT
9713     memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9714 #else
9715     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9716 #endif
9717 #ifndef _USE_STD_STAT
9718     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9719     statbufp->st_devnam[63] = 0;
9720     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9721 #else
9722     /* todo:
9723      * The device is only encoded so that Perl_cando can use it to
9724      * look up ACLS.  So rmsexpand it to the 255 character version
9725      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9726      * for long filenames and symbolic links first.  This also seems
9727      * to remove the need for a namecache that could be stale.
9728      */
9729 #endif
9730
9731 #   ifdef RTL_USES_UTC
9732 #   ifdef VMSISH_TIME
9733     if (VMSISH_TIME) {
9734       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9735       statbufp->st_atime = _toloc(statbufp->st_atime);
9736       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9737     }
9738 #   endif
9739 #   else
9740 #   ifdef VMSISH_TIME
9741     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9742 #   else
9743     if (1) {
9744 #   endif
9745       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9746       statbufp->st_atime = _toutc(statbufp->st_atime);
9747       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9748     }
9749 #endif
9750     return 0;
9751   }
9752   return -1;
9753
9754 }  /* end of flex_fstat() */
9755 /*}}}*/
9756
9757 #if !defined(__VAX) && __CRTL_VER >= 80200000
9758 #ifdef lstat
9759 #undef lstat
9760 #endif
9761 #else
9762 #ifdef lstat
9763 #undef lstat
9764 #endif
9765 #define lstat(_x, _y) stat(_x, _y)
9766 #endif
9767
9768 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9769
9770 static int
9771 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9772 {
9773     char fileified[NAM$C_MAXRSS+1];
9774     char temp_fspec[NAM$C_MAXRSS+300];
9775     int retval = -1;
9776     int saved_errno, saved_vaxc_errno;
9777
9778     if (!fspec) return retval;
9779     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9780     strcpy(temp_fspec, fspec);
9781     if (statbufp == (Stat_t *) &PL_statcache)
9782       do_tovmsspec(temp_fspec,namecache,0);
9783     if (decc_bug_devnull != 0) {
9784       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9785         memset(statbufp,0,sizeof *statbufp);
9786         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9787         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9788         statbufp->st_uid = 0x00010001;
9789         statbufp->st_gid = 0x0001;
9790         time((time_t *)&statbufp->st_mtime);
9791         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9792         return 0;
9793       }
9794     }
9795
9796     /* Try for a directory name first.  If fspec contains a filename without
9797      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9798      * and sea:[wine.dark]water. exist, we prefer the directory here.
9799      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9800      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9801      * the file with null type, specify this by calling flex_stat() with
9802      * a '.' at the end of fspec.
9803      *
9804      * If we are in Posix filespec mode, accept the filename as is.
9805      */
9806 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9807   if (decc_posix_compliant_pathnames == 0) {
9808 #endif
9809     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9810       if (lstat_flag == 0)
9811         retval = stat(fileified,(stat_t *) statbufp);
9812       else
9813         retval = lstat(fileified,(stat_t *) statbufp);
9814       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9815         strcpy(namecache,fileified);
9816     }
9817     if (retval) {
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 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9824   } else {
9825     if (lstat_flag == 0)
9826       retval = stat(temp_fspec,(stat_t *) statbufp);
9827     else
9828       retval = lstat(temp_fspec,(stat_t *) statbufp);
9829   }
9830 #endif
9831     if (!retval) {
9832 #ifdef _USE_STD_STAT
9833       memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9834 #else
9835       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9836 #endif
9837 #ifndef _USE_STD_STAT
9838       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9839       statbufp->st_devnam[63] = 0;
9840       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9841 #else
9842     /* todo:
9843      * The device is only encoded so that Perl_cando can use it to
9844      * look up ACLS.  So rmsexpand it to the 255 character version
9845      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9846      * for long filenames and symbolic links first.  This also seems
9847      * to remove the need for a namecache that could be stale.
9848      */
9849 #endif
9850 #     ifdef RTL_USES_UTC
9851 #     ifdef VMSISH_TIME
9852       if (VMSISH_TIME) {
9853         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9854         statbufp->st_atime = _toloc(statbufp->st_atime);
9855         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9856       }
9857 #     endif
9858 #     else
9859 #     ifdef VMSISH_TIME
9860       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9861 #     else
9862       if (1) {
9863 #     endif
9864         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9865         statbufp->st_atime = _toutc(statbufp->st_atime);
9866         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9867       }
9868 #     endif
9869     }
9870     /* If we were successful, leave errno where we found it */
9871     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9872     return retval;
9873
9874 }  /* end of flex_stat_int() */
9875
9876
9877 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9878 int
9879 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9880 {
9881    return flex_stat_int(fspec, statbufp, 0);
9882 }
9883 /*}}}*/
9884
9885 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9886 int
9887 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9888 {
9889    return flex_stat_int(fspec, statbufp, 1);
9890 }
9891 /*}}}*/
9892
9893
9894 /*{{{char *my_getlogin()*/
9895 /* VMS cuserid == Unix getlogin, except calling sequence */
9896 char *
9897 my_getlogin(void)
9898 {
9899     static char user[L_cuserid];
9900     return cuserid(user);
9901 }
9902 /*}}}*/
9903
9904
9905 /*  rmscopy - copy a file using VMS RMS routines
9906  *
9907  *  Copies contents and attributes of spec_in to spec_out, except owner
9908  *  and protection information.  Name and type of spec_in are used as
9909  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9910  *  should try to propagate timestamps from the input file to the output file.
9911  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9912  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9913  *  propagated to the output file at creation iff the output file specification
9914  *  did not contain an explicit name or type, and the revision date is always
9915  *  updated at the end of the copy operation.  If it is greater than 0, then
9916  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9917  *  other than the revision date should be propagated, and bit 1 indicates
9918  *  that the revision date should be propagated.
9919  *
9920  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9921  *
9922  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9923  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9924  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9925  * as part of the Perl standard distribution under the terms of the
9926  * GNU General Public License or the Perl Artistic License.  Copies
9927  * of each may be found in the Perl standard distribution.
9928  */ /* FIXME */
9929 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9930 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9931 int
9932 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9933 {
9934     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9935          rsa[NAM$C_MAXRSS], ubf[32256];
9936     unsigned long int i, sts, sts2;
9937     struct FAB fab_in, fab_out;
9938     struct RAB rab_in, rab_out;
9939     struct NAM nam;
9940     struct XABDAT xabdat;
9941     struct XABFHC xabfhc;
9942     struct XABRDT xabrdt;
9943     struct XABSUM xabsum;
9944
9945     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9946         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9947       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9948       return 0;
9949     }
9950
9951     fab_in = cc$rms_fab;
9952     fab_in.fab$l_fna = vmsin;
9953     fab_in.fab$b_fns = strlen(vmsin);
9954     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9955     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9956     fab_in.fab$l_fop = FAB$M_SQO;
9957     fab_in.fab$l_nam =  &nam;
9958     fab_in.fab$l_xab = (void *) &xabdat;
9959
9960     nam = cc$rms_nam;
9961     nam.nam$l_rsa = rsa;
9962     nam.nam$b_rss = sizeof(rsa);
9963     nam.nam$l_esa = esa;
9964     nam.nam$b_ess = sizeof (esa);
9965     nam.nam$b_esl = nam.nam$b_rsl = 0;
9966 #ifdef NAM$M_NO_SHORT_UPCASE
9967     if (decc_efs_case_preserve)
9968         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9969 #endif
9970
9971     xabdat = cc$rms_xabdat;        /* To get creation date */
9972     xabdat.xab$l_nxt = (void *) &xabfhc;
9973
9974     xabfhc = cc$rms_xabfhc;        /* To get record length */
9975     xabfhc.xab$l_nxt = (void *) &xabsum;
9976
9977     xabsum = cc$rms_xabsum;        /* To get key and area information */
9978
9979     if (!((sts = sys$open(&fab_in)) & 1)) {
9980       set_vaxc_errno(sts);
9981       switch (sts) {
9982         case RMS$_FNF: case RMS$_DNF:
9983           set_errno(ENOENT); break;
9984         case RMS$_DIR:
9985           set_errno(ENOTDIR); break;
9986         case RMS$_DEV:
9987           set_errno(ENODEV); break;
9988         case RMS$_SYN:
9989           set_errno(EINVAL); break;
9990         case RMS$_PRV:
9991           set_errno(EACCES); break;
9992         default:
9993           set_errno(EVMSERR);
9994       }
9995       return 0;
9996     }
9997
9998     fab_out = fab_in;
9999     fab_out.fab$w_ifi = 0;
10000     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10001     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10002     fab_out.fab$l_fop = FAB$M_SQO;
10003     fab_out.fab$l_fna = vmsout;
10004     fab_out.fab$b_fns = strlen(vmsout);
10005     fab_out.fab$l_dna = nam.nam$l_name;
10006     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10007
10008     if (preserve_dates == 0) {  /* Act like DCL COPY */
10009       nam.nam$b_nop |= NAM$M_SYNCHK;
10010       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10011       if (!((sts = sys$parse(&fab_out)) & 1)) {
10012         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10013         set_vaxc_errno(sts);
10014         return 0;
10015       }
10016       fab_out.fab$l_xab = (void *) &xabdat;
10017       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10018     }
10019     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10020     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10021       preserve_dates =0;      /* bitmask from this point forward   */
10022
10023     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10024     if (!((sts = sys$create(&fab_out)) & 1)) {
10025       set_vaxc_errno(sts);
10026       switch (sts) {
10027         case RMS$_DNF:
10028           set_errno(ENOENT); break;
10029         case RMS$_DIR:
10030           set_errno(ENOTDIR); break;
10031         case RMS$_DEV:
10032           set_errno(ENODEV); break;
10033         case RMS$_SYN:
10034           set_errno(EINVAL); break;
10035         case RMS$_PRV:
10036           set_errno(EACCES); break;
10037         default:
10038           set_errno(EVMSERR);
10039       }
10040       return 0;
10041     }
10042     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10043     if (preserve_dates & 2) {
10044       /* sys$close() will process xabrdt, not xabdat */
10045       xabrdt = cc$rms_xabrdt;
10046 #ifndef __GNUC__
10047       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10048 #else
10049       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10050        * is unsigned long[2], while DECC & VAXC use a struct */
10051       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10052 #endif
10053       fab_out.fab$l_xab = (void *) &xabrdt;
10054     }
10055
10056     rab_in = cc$rms_rab;
10057     rab_in.rab$l_fab = &fab_in;
10058     rab_in.rab$l_rop = RAB$M_BIO;
10059     rab_in.rab$l_ubf = ubf;
10060     rab_in.rab$w_usz = sizeof ubf;
10061     if (!((sts = sys$connect(&rab_in)) & 1)) {
10062       sys$close(&fab_in); sys$close(&fab_out);
10063       set_errno(EVMSERR); set_vaxc_errno(sts);
10064       return 0;
10065     }
10066
10067     rab_out = cc$rms_rab;
10068     rab_out.rab$l_fab = &fab_out;
10069     rab_out.rab$l_rbf = ubf;
10070     if (!((sts = sys$connect(&rab_out)) & 1)) {
10071       sys$close(&fab_in); sys$close(&fab_out);
10072       set_errno(EVMSERR); set_vaxc_errno(sts);
10073       return 0;
10074     }
10075
10076     while ((sts = sys$read(&rab_in))) {  /* always true  */
10077       if (sts == RMS$_EOF) break;
10078       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10079       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10080         sys$close(&fab_in); sys$close(&fab_out);
10081         set_errno(EVMSERR); set_vaxc_errno(sts);
10082         return 0;
10083       }
10084     }
10085
10086     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10087     sys$close(&fab_in);  sys$close(&fab_out);
10088     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10089     if (!(sts & 1)) {
10090       set_errno(EVMSERR); set_vaxc_errno(sts);
10091       return 0;
10092     }
10093
10094     return 1;
10095
10096 }  /* end of rmscopy() */
10097 #else
10098 /* ODS-5 support version */
10099 int
10100 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10101 {
10102     char *vmsin, * vmsout, *esa, *esa_out,
10103          *rsa, *ubf;
10104     unsigned long int i, sts, sts2;
10105     struct FAB fab_in, fab_out;
10106     struct RAB rab_in, rab_out;
10107     struct NAML nam;
10108     struct NAML nam_out;
10109     struct XABDAT xabdat;
10110     struct XABFHC xabfhc;
10111     struct XABRDT xabrdt;
10112     struct XABSUM xabsum;
10113
10114     Newx(vmsin, VMS_MAXRSS, char);
10115     Newx(vmsout, VMS_MAXRSS, char);
10116     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10117         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10118       Safefree(vmsin);
10119       Safefree(vmsout);
10120       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10121       return 0;
10122     }
10123
10124     Newx(esa, VMS_MAXRSS, char);
10125     nam = cc$rms_naml;
10126     fab_in = cc$rms_fab;
10127     fab_in.fab$l_fna = (char *) -1;
10128     fab_in.fab$b_fns = 0;
10129     nam.naml$l_long_filename = vmsin;
10130     nam.naml$l_long_filename_size = strlen(vmsin);
10131     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10132     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10133     fab_in.fab$l_fop = FAB$M_SQO;
10134     fab_in.fab$l_naml =  &nam;
10135     fab_in.fab$l_xab = (void *) &xabdat;
10136
10137     Newx(rsa, VMS_MAXRSS, char);
10138     nam.naml$l_rsa = NULL;
10139     nam.naml$b_rss = 0;
10140     nam.naml$l_long_result = rsa;
10141     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10142     nam.naml$l_esa = NULL;
10143     nam.naml$b_ess = 0;
10144     nam.naml$l_long_expand = esa;
10145     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10146     nam.naml$b_esl = nam.naml$b_rsl = 0;
10147     nam.naml$l_long_expand_size = 0;
10148     nam.naml$l_long_result_size = 0;
10149 #ifdef NAM$M_NO_SHORT_UPCASE
10150     if (decc_efs_case_preserve)
10151         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10152 #endif
10153
10154     xabdat = cc$rms_xabdat;        /* To get creation date */
10155     xabdat.xab$l_nxt = (void *) &xabfhc;
10156
10157     xabfhc = cc$rms_xabfhc;        /* To get record length */
10158     xabfhc.xab$l_nxt = (void *) &xabsum;
10159
10160     xabsum = cc$rms_xabsum;        /* To get key and area information */
10161
10162     if (!((sts = sys$open(&fab_in)) & 1)) {
10163       Safefree(vmsin);
10164       Safefree(vmsout);
10165       Safefree(esa);
10166       Safefree(rsa);
10167       set_vaxc_errno(sts);
10168       switch (sts) {
10169         case RMS$_FNF: case RMS$_DNF:
10170           set_errno(ENOENT); break;
10171         case RMS$_DIR:
10172           set_errno(ENOTDIR); break;
10173         case RMS$_DEV:
10174           set_errno(ENODEV); break;
10175         case RMS$_SYN:
10176           set_errno(EINVAL); break;
10177         case RMS$_PRV:
10178           set_errno(EACCES); break;
10179         default:
10180           set_errno(EVMSERR);
10181       }
10182       return 0;
10183     }
10184
10185     nam_out = nam;
10186     fab_out = fab_in;
10187     fab_out.fab$w_ifi = 0;
10188     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10189     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10190     fab_out.fab$l_fop = FAB$M_SQO;
10191     fab_out.fab$l_naml = &nam_out;
10192     fab_out.fab$l_fna = (char *) -1;
10193     fab_out.fab$b_fns = 0;
10194     nam_out.naml$l_long_filename = vmsout;
10195     nam_out.naml$l_long_filename_size = strlen(vmsout);
10196     fab_out.fab$l_dna = (char *) -1;
10197     fab_out.fab$b_dns = 0;
10198     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10199     nam_out.naml$l_long_defname_size =
10200         nam.naml$l_long_name ?
10201            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10202
10203     Newx(esa_out, VMS_MAXRSS, char);
10204     nam_out.naml$l_rsa = NULL;
10205     nam_out.naml$b_rss = 0;
10206     nam_out.naml$l_long_result = NULL;
10207     nam_out.naml$l_long_result_alloc = 0;
10208     nam_out.naml$l_esa = NULL;
10209     nam_out.naml$b_ess = 0;
10210     nam_out.naml$l_long_expand = esa_out;
10211     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10212
10213     if (preserve_dates == 0) {  /* Act like DCL COPY */
10214       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10215       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10216       if (!((sts = sys$parse(&fab_out)) & 1)) {
10217         Safefree(vmsin);
10218         Safefree(vmsout);
10219         Safefree(esa);
10220         Safefree(rsa);
10221         Safefree(esa_out);
10222         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10223         set_vaxc_errno(sts);
10224         return 0;
10225       }
10226       fab_out.fab$l_xab = (void *) &xabdat;
10227       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10228     }
10229     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10230       preserve_dates =0;      /* bitmask from this point forward   */
10231
10232     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10233     if (!((sts = sys$create(&fab_out)) & 1)) {
10234       Safefree(vmsin);
10235       Safefree(vmsout);
10236       Safefree(esa);
10237       Safefree(rsa);
10238       Safefree(esa_out);
10239       set_vaxc_errno(sts);
10240       switch (sts) {
10241         case RMS$_DNF:
10242           set_errno(ENOENT); break;
10243         case RMS$_DIR:
10244           set_errno(ENOTDIR); break;
10245         case RMS$_DEV:
10246           set_errno(ENODEV); break;
10247         case RMS$_SYN:
10248           set_errno(EINVAL); break;
10249         case RMS$_PRV:
10250           set_errno(EACCES); break;
10251         default:
10252           set_errno(EVMSERR);
10253       }
10254       return 0;
10255     }
10256     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10257     if (preserve_dates & 2) {
10258       /* sys$close() will process xabrdt, not xabdat */
10259       xabrdt = cc$rms_xabrdt;
10260 #ifndef __GNUC__
10261       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10262 #else
10263       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10264        * is unsigned long[2], while DECC & VAXC use a struct */
10265       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10266 #endif
10267       fab_out.fab$l_xab = (void *) &xabrdt;
10268     }
10269
10270     Newx(ubf, 32256, char);
10271     rab_in = cc$rms_rab;
10272     rab_in.rab$l_fab = &fab_in;
10273     rab_in.rab$l_rop = RAB$M_BIO;
10274     rab_in.rab$l_ubf = ubf;
10275     rab_in.rab$w_usz = 32256;
10276     if (!((sts = sys$connect(&rab_in)) & 1)) {
10277       sys$close(&fab_in); sys$close(&fab_out);
10278       Safefree(vmsin);
10279       Safefree(vmsout);
10280       Safefree(esa);
10281       Safefree(ubf);
10282       Safefree(rsa);
10283       Safefree(esa_out);
10284       set_errno(EVMSERR); set_vaxc_errno(sts);
10285       return 0;
10286     }
10287
10288     rab_out = cc$rms_rab;
10289     rab_out.rab$l_fab = &fab_out;
10290     rab_out.rab$l_rbf = ubf;
10291     if (!((sts = sys$connect(&rab_out)) & 1)) {
10292       sys$close(&fab_in); sys$close(&fab_out);
10293       Safefree(vmsin);
10294       Safefree(vmsout);
10295       Safefree(esa);
10296       Safefree(ubf);
10297       Safefree(rsa);
10298       Safefree(esa_out);
10299       set_errno(EVMSERR); set_vaxc_errno(sts);
10300       return 0;
10301     }
10302
10303     while ((sts = sys$read(&rab_in))) {  /* always true  */
10304       if (sts == RMS$_EOF) break;
10305       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10306       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10307         sys$close(&fab_in); sys$close(&fab_out);
10308         Safefree(vmsin);
10309         Safefree(vmsout);
10310         Safefree(esa);
10311         Safefree(ubf);
10312         Safefree(rsa);
10313         Safefree(esa_out);
10314         set_errno(EVMSERR); set_vaxc_errno(sts);
10315         return 0;
10316       }
10317     }
10318
10319
10320     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10321     sys$close(&fab_in);  sys$close(&fab_out);
10322     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10323     if (!(sts & 1)) {
10324       Safefree(vmsin);
10325       Safefree(vmsout);
10326       Safefree(esa);
10327       Safefree(ubf);
10328       Safefree(rsa);
10329       Safefree(esa_out);
10330       set_errno(EVMSERR); set_vaxc_errno(sts);
10331       return 0;
10332     }
10333
10334     Safefree(vmsin);
10335     Safefree(vmsout);
10336     Safefree(esa);
10337     Safefree(ubf);
10338     Safefree(rsa);
10339     Safefree(esa_out);
10340     return 1;
10341
10342 }  /* end of rmscopy() */
10343 #endif
10344 /*}}}*/
10345
10346
10347 /***  The following glue provides 'hooks' to make some of the routines
10348  * from this file available from Perl.  These routines are sufficiently
10349  * basic, and are required sufficiently early in the build process,
10350  * that's it's nice to have them available to miniperl as well as the
10351  * full Perl, so they're set up here instead of in an extension.  The
10352  * Perl code which handles importation of these names into a given
10353  * package lives in [.VMS]Filespec.pm in @INC.
10354  */
10355
10356 void
10357 rmsexpand_fromperl(pTHX_ CV *cv)
10358 {
10359   dXSARGS;
10360   char *fspec, *defspec = NULL, *rslt;
10361   STRLEN n_a;
10362
10363   if (!items || items > 2)
10364     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10365   fspec = SvPV(ST(0),n_a);
10366   if (!fspec || !*fspec) XSRETURN_UNDEF;
10367   if (items == 2) defspec = SvPV(ST(1),n_a);
10368
10369   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10370   ST(0) = sv_newmortal();
10371   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10372   XSRETURN(1);
10373 }
10374
10375 void
10376 vmsify_fromperl(pTHX_ CV *cv)
10377 {
10378   dXSARGS;
10379   char *vmsified;
10380   STRLEN n_a;
10381
10382   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10383   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10384   ST(0) = sv_newmortal();
10385   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10386   XSRETURN(1);
10387 }
10388
10389 void
10390 unixify_fromperl(pTHX_ CV *cv)
10391 {
10392   dXSARGS;
10393   char *unixified;
10394   STRLEN n_a;
10395
10396   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10397   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10398   ST(0) = sv_newmortal();
10399   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10400   XSRETURN(1);
10401 }
10402
10403 void
10404 fileify_fromperl(pTHX_ CV *cv)
10405 {
10406   dXSARGS;
10407   char *fileified;
10408   STRLEN n_a;
10409
10410   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10411   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10412   ST(0) = sv_newmortal();
10413   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10414   XSRETURN(1);
10415 }
10416
10417 void
10418 pathify_fromperl(pTHX_ CV *cv)
10419 {
10420   dXSARGS;
10421   char *pathified;
10422   STRLEN n_a;
10423
10424   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10425   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10426   ST(0) = sv_newmortal();
10427   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10428   XSRETURN(1);
10429 }
10430
10431 void
10432 vmspath_fromperl(pTHX_ CV *cv)
10433 {
10434   dXSARGS;
10435   char *vmspath;
10436   STRLEN n_a;
10437
10438   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10439   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10440   ST(0) = sv_newmortal();
10441   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10442   XSRETURN(1);
10443 }
10444
10445 void
10446 unixpath_fromperl(pTHX_ CV *cv)
10447 {
10448   dXSARGS;
10449   char *unixpath;
10450   STRLEN n_a;
10451
10452   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10453   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10454   ST(0) = sv_newmortal();
10455   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10456   XSRETURN(1);
10457 }
10458
10459 void
10460 candelete_fromperl(pTHX_ CV *cv)
10461 {
10462   dXSARGS;
10463   char fspec[NAM$C_MAXRSS+1], *fsp;
10464   SV *mysv;
10465   IO *io;
10466   STRLEN n_a;
10467
10468   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10469
10470   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10471   if (SvTYPE(mysv) == SVt_PVGV) {
10472     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10473       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10474       ST(0) = &PL_sv_no;
10475       XSRETURN(1);
10476     }
10477     fsp = fspec;
10478   }
10479   else {
10480     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10481       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10482       ST(0) = &PL_sv_no;
10483       XSRETURN(1);
10484     }
10485   }
10486
10487   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10488   XSRETURN(1);
10489 }
10490
10491 void
10492 rmscopy_fromperl(pTHX_ CV *cv)
10493 {
10494   dXSARGS;
10495   char *inspec, *outspec, *inp, *outp;
10496   int date_flag;
10497   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10498                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10499   unsigned long int sts;
10500   SV *mysv;
10501   IO *io;
10502   STRLEN n_a;
10503
10504   if (items < 2 || items > 3)
10505     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10506
10507   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10508   Newx(inspec, VMS_MAXRSS, char);
10509   if (SvTYPE(mysv) == SVt_PVGV) {
10510     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10511       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10512       ST(0) = &PL_sv_no;
10513       Safefree(inspec);
10514       XSRETURN(1);
10515     }
10516     inp = inspec;
10517   }
10518   else {
10519     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10520       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10521       ST(0) = &PL_sv_no;
10522       Safefree(inspec);
10523       XSRETURN(1);
10524     }
10525   }
10526   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10527   Newx(outspec, VMS_MAXRSS, char);
10528   if (SvTYPE(mysv) == SVt_PVGV) {
10529     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10530       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10531       ST(0) = &PL_sv_no;
10532       Safefree(inspec);
10533       Safefree(outspec);
10534       XSRETURN(1);
10535     }
10536     outp = outspec;
10537   }
10538   else {
10539     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10540       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10541       ST(0) = &PL_sv_no;
10542       Safefree(inspec);
10543       Safefree(outspec);
10544       XSRETURN(1);
10545     }
10546   }
10547   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10548
10549   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10550   Safefree(inspec);
10551   Safefree(outspec);
10552   XSRETURN(1);
10553 }
10554
10555 /* The mod2fname is limited to shorter filenames by design, so it should
10556  * not be modified to support longer EFS pathnames
10557  */
10558 void
10559 mod2fname(pTHX_ CV *cv)
10560 {
10561   dXSARGS;
10562   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10563        workbuff[NAM$C_MAXRSS*1 + 1];
10564   int total_namelen = 3, counter, num_entries;
10565   /* ODS-5 ups this, but we want to be consistent, so... */
10566   int max_name_len = 39;
10567   AV *in_array = (AV *)SvRV(ST(0));
10568
10569   num_entries = av_len(in_array);
10570
10571   /* All the names start with PL_. */
10572   strcpy(ultimate_name, "PL_");
10573
10574   /* Clean up our working buffer */
10575   Zero(work_name, sizeof(work_name), char);
10576
10577   /* Run through the entries and build up a working name */
10578   for(counter = 0; counter <= num_entries; counter++) {
10579     /* If it's not the first name then tack on a __ */
10580     if (counter) {
10581       strcat(work_name, "__");
10582     }
10583     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10584                            PL_na));
10585   }
10586
10587   /* Check to see if we actually have to bother...*/
10588   if (strlen(work_name) + 3 <= max_name_len) {
10589     strcat(ultimate_name, work_name);
10590   } else {
10591     /* It's too darned big, so we need to go strip. We use the same */
10592     /* algorithm as xsubpp does. First, strip out doubled __ */
10593     char *source, *dest, last;
10594     dest = workbuff;
10595     last = 0;
10596     for (source = work_name; *source; source++) {
10597       if (last == *source && last == '_') {
10598         continue;
10599       }
10600       *dest++ = *source;
10601       last = *source;
10602     }
10603     /* Go put it back */
10604     strcpy(work_name, workbuff);
10605     /* Is it still too big? */
10606     if (strlen(work_name) + 3 > max_name_len) {
10607       /* Strip duplicate letters */
10608       last = 0;
10609       dest = workbuff;
10610       for (source = work_name; *source; source++) {
10611         if (last == toupper(*source)) {
10612         continue;
10613         }
10614         *dest++ = *source;
10615         last = toupper(*source);
10616       }
10617       strcpy(work_name, workbuff);
10618     }
10619
10620     /* Is it *still* too big? */
10621     if (strlen(work_name) + 3 > max_name_len) {
10622       /* Too bad, we truncate */
10623       work_name[max_name_len - 2] = 0;
10624     }
10625     strcat(ultimate_name, work_name);
10626   }
10627
10628   /* Okay, return it */
10629   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10630   XSRETURN(1);
10631 }
10632
10633 void
10634 hushexit_fromperl(pTHX_ CV *cv)
10635 {
10636     dXSARGS;
10637
10638     if (items > 0) {
10639         VMSISH_HUSHED = SvTRUE(ST(0));
10640     }
10641     ST(0) = boolSV(VMSISH_HUSHED);
10642     XSRETURN(1);
10643 }
10644
10645 #ifdef HAS_SYMLINK
10646 static char *
10647 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10648
10649 void
10650 vms_realpath_fromperl(pTHX_ CV *cv)
10651 {
10652   dXSARGS;
10653   char *fspec, *rslt_spec, *rslt;
10654   STRLEN n_a;
10655
10656   if (!items || items != 1)
10657     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10658
10659   fspec = SvPV(ST(0),n_a);
10660   if (!fspec || !*fspec) XSRETURN_UNDEF;
10661
10662   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10663   rslt = do_vms_realpath(fspec, rslt_spec);
10664   ST(0) = sv_newmortal();
10665   if (rslt != NULL)
10666     sv_usepvn(ST(0),rslt,strlen(rslt));
10667   else
10668     Safefree(rslt_spec);
10669   XSRETURN(1);
10670 }
10671 #endif
10672
10673 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10674 int do_vms_case_tolerant(void);
10675
10676 void
10677 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10678 {
10679   dXSARGS;
10680   ST(0) = boolSV(do_vms_case_tolerant());
10681   XSRETURN(1);
10682 }
10683 #endif
10684
10685 void
10686 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10687                           struct interp_intern *dst)
10688 {
10689     memcpy(dst,src,sizeof(struct interp_intern));
10690 }
10691
10692 void
10693 Perl_sys_intern_clear(pTHX)
10694 {
10695 }
10696
10697 void
10698 Perl_sys_intern_init(pTHX)
10699 {
10700     unsigned int ix = RAND_MAX;
10701     double x;
10702
10703     VMSISH_HUSHED = 0;
10704
10705     /* fix me later to track running under GNV */
10706     /* this allows some limited testing */
10707     MY_POSIX_EXIT = decc_filename_unix_report;
10708
10709     x = (float)ix;
10710     MY_INV_RAND_MAX = 1./x;
10711 }
10712
10713 void
10714 init_os_extras(void)
10715 {
10716   dTHX;
10717   char* file = __FILE__;
10718   char temp_buff[512];
10719   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10720     no_translate_barewords = TRUE;
10721   } else {
10722     no_translate_barewords = FALSE;
10723   }
10724
10725   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10726   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10727   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10728   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10729   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10730   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10731   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10732   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10733   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10734   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10735   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10736 #ifdef HAS_SYMLINK
10737   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10738 #endif
10739 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10740   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10741 #endif
10742
10743   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10744
10745   return;
10746 }
10747
10748 #ifdef HAS_SYMLINK
10749
10750 #if __CRTL_VER == 80200000
10751 /* This missed getting in to the DECC SDK for 8.2 */
10752 char *realpath(const char *file_name, char * resolved_name, ...);
10753 #endif
10754
10755 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10756 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10757  * The perl fallback routine to provide realpath() is not as efficient
10758  * on OpenVMS.
10759  */
10760 static char *
10761 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10762 {
10763     return realpath(filespec, outbuf);
10764 }
10765
10766 /*}}}*/
10767 /* External entry points */
10768 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10769 { return do_vms_realpath(filespec, outbuf); }
10770 #else
10771 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10772 { return NULL; }
10773 #endif
10774
10775
10776 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10777 /* case_tolerant */
10778
10779 /*{{{int do_vms_case_tolerant(void)*/
10780 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10781  * controlled by a process setting.
10782  */
10783 int do_vms_case_tolerant(void)
10784 {
10785     return vms_process_case_tolerant;
10786 }
10787 /*}}}*/
10788 /* External entry points */
10789 int Perl_vms_case_tolerant(void)
10790 { return do_vms_case_tolerant(); }
10791 #else
10792 int Perl_vms_case_tolerant(void)
10793 { return vms_process_case_tolerant; }
10794 #endif
10795
10796
10797  /* Start of DECC RTL Feature handling */
10798
10799 static int sys_trnlnm
10800    (const char * logname,
10801     char * value,
10802     int value_len)
10803 {
10804     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10805     const unsigned long attr = LNM$M_CASE_BLIND;
10806     struct dsc$descriptor_s name_dsc;
10807     int status;
10808     unsigned short result;
10809     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10810                                 {0, 0, 0, 0}};
10811
10812     name_dsc.dsc$w_length = strlen(logname);
10813     name_dsc.dsc$a_pointer = (char *)logname;
10814     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10815     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10816
10817     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10818
10819     if ($VMS_STATUS_SUCCESS(status)) {
10820
10821          /* Null terminate and return the string */
10822         /*--------------------------------------*/
10823         value[result] = 0;
10824     }
10825
10826     return status;
10827 }
10828
10829 static int sys_crelnm
10830    (const char * logname,
10831     const char * value)
10832 {
10833     int ret_val;
10834     const char * proc_table = "LNM$PROCESS_TABLE";
10835     struct dsc$descriptor_s proc_table_dsc;
10836     struct dsc$descriptor_s logname_dsc;
10837     struct itmlst_3 item_list[2];
10838
10839     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10840     proc_table_dsc.dsc$w_length = strlen(proc_table);
10841     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10842     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10843
10844     logname_dsc.dsc$a_pointer = (char *) logname;
10845     logname_dsc.dsc$w_length = strlen(logname);
10846     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10847     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10848
10849     item_list[0].buflen = strlen(value);
10850     item_list[0].itmcode = LNM$_STRING;
10851     item_list[0].bufadr = (char *)value;
10852     item_list[0].retlen = NULL;
10853
10854     item_list[1].buflen = 0;
10855     item_list[1].itmcode = 0;
10856
10857     ret_val = sys$crelnm
10858                        (NULL,
10859                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10860                         (const struct dsc$descriptor_s *)&logname_dsc,
10861                         NULL,
10862                         (const struct item_list_3 *) item_list);
10863
10864     return ret_val;
10865 }
10866
10867
10868 /* C RTL Feature settings */
10869
10870 static int set_features
10871    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10872     int (* cli_routine)(void),  /* Not documented */
10873     void *image_info)           /* Not documented */
10874 {
10875     int status;
10876     int s;
10877     int dflt;
10878     char* str;
10879     char val_str[10];
10880     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10881     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10882     unsigned long case_perm;
10883     unsigned long case_image;
10884
10885     /* hacks to see if known bugs are still present for testing */
10886
10887     /* Readdir is returning filenames in VMS syntax always */
10888     decc_bug_readdir_efs1 = 1;
10889     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10890     if ($VMS_STATUS_SUCCESS(status)) {
10891        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10892          decc_bug_readdir_efs1 = 1;
10893        else
10894          decc_bug_readdir_efs1 = 0;
10895     }
10896
10897     /* PCP mode requires creating /dev/null special device file */
10898     decc_bug_devnull = 0;
10899     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10900     if ($VMS_STATUS_SUCCESS(status)) {
10901        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10902           decc_bug_devnull = 1;
10903     }
10904
10905     /* fgetname returning a VMS name in UNIX mode */
10906     decc_bug_fgetname = 1;
10907     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10908     if ($VMS_STATUS_SUCCESS(status)) {
10909       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10910         decc_bug_fgetname = 1;
10911       else
10912         decc_bug_fgetname = 0;
10913     }
10914
10915     /* UNIX directory names with no paths are broken in a lot of places */
10916     decc_dir_barename = 1;
10917     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10918     if ($VMS_STATUS_SUCCESS(status)) {
10919       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10920         decc_dir_barename = 1;
10921       else
10922         decc_dir_barename = 0;
10923     }
10924
10925 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10926     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10927     if (s >= 0) {
10928         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10929         if (decc_disable_to_vms_logname_translation < 0)
10930             decc_disable_to_vms_logname_translation = 0;
10931     }
10932
10933     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10934     if (s >= 0) {
10935         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10936         if (decc_efs_case_preserve < 0)
10937             decc_efs_case_preserve = 0;
10938     }
10939
10940     s = decc$feature_get_index("DECC$EFS_CHARSET");
10941     if (s >= 0) {
10942         decc_efs_charset = decc$feature_get_value(s, 1);
10943         if (decc_efs_charset < 0)
10944             decc_efs_charset = 0;
10945     }
10946
10947     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10948     if (s >= 0) {
10949         decc_filename_unix_report = decc$feature_get_value(s, 1);
10950         if (decc_filename_unix_report > 0)
10951             decc_filename_unix_report = 1;
10952         else
10953             decc_filename_unix_report = 0;
10954     }
10955
10956     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10957     if (s >= 0) {
10958         decc_filename_unix_only = decc$feature_get_value(s, 1);
10959         if (decc_filename_unix_only > 0) {
10960             decc_filename_unix_only = 1;
10961         }
10962         else {
10963             decc_filename_unix_only = 0;
10964         }
10965     }
10966
10967     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10968     if (s >= 0) {
10969         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10970         if (decc_filename_unix_no_version < 0)
10971             decc_filename_unix_no_version = 0;
10972     }
10973
10974     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10975     if (s >= 0) {
10976         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10977         if (decc_readdir_dropdotnotype < 0)
10978             decc_readdir_dropdotnotype = 0;
10979     }
10980
10981     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10982     if ($VMS_STATUS_SUCCESS(status)) {
10983         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10984         if (s >= 0) {
10985             dflt = decc$feature_get_value(s, 4);
10986             if (dflt > 0) {
10987                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10988                 if (decc_disable_posix_root <= 0) {
10989                     decc$feature_set_value(s, 1, 1);
10990                     decc_disable_posix_root = 1;
10991                 }
10992             }
10993             else {
10994                 /* Traditionally Perl assumes this is off */
10995                 decc_disable_posix_root = 1;
10996                 decc$feature_set_value(s, 1, 1);
10997             }
10998         }
10999     }
11000
11001 #if __CRTL_VER >= 80200000
11002     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11003     if (s >= 0) {
11004         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11005         if (decc_posix_compliant_pathnames < 0)
11006             decc_posix_compliant_pathnames = 0;
11007         if (decc_posix_compliant_pathnames > 4)
11008             decc_posix_compliant_pathnames = 0;
11009     }
11010
11011 #endif
11012 #else
11013     status = sys_trnlnm
11014         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11015     if ($VMS_STATUS_SUCCESS(status)) {
11016         val_str[0] = _toupper(val_str[0]);
11017         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11018            decc_disable_to_vms_logname_translation = 1;
11019         }
11020     }
11021
11022 #ifndef __VAX
11023     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11024     if ($VMS_STATUS_SUCCESS(status)) {
11025         val_str[0] = _toupper(val_str[0]);
11026         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11027            decc_efs_case_preserve = 1;
11028         }
11029     }
11030 #endif
11031
11032     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", 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_report = 1;
11037         }
11038     }
11039     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11040     if ($VMS_STATUS_SUCCESS(status)) {
11041         val_str[0] = _toupper(val_str[0]);
11042         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11043            decc_filename_unix_only = 1;
11044            decc_filename_unix_report = 1;
11045         }
11046     }
11047     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", 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_filename_unix_no_version = 1;
11052         }
11053     }
11054     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11055     if ($VMS_STATUS_SUCCESS(status)) {
11056         val_str[0] = _toupper(val_str[0]);
11057         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11058            decc_readdir_dropdotnotype = 1;
11059         }
11060     }
11061 #endif
11062
11063 #ifndef __VAX
11064
11065      /* Report true case tolerance */
11066     /*----------------------------*/
11067     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11068     if (!$VMS_STATUS_SUCCESS(status))
11069         case_perm = PPROP$K_CASE_BLIND;
11070     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11071     if (!$VMS_STATUS_SUCCESS(status))
11072         case_image = PPROP$K_CASE_BLIND;
11073     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11074         (case_image == PPROP$K_CASE_SENSITIVE))
11075         vms_process_case_tolerant = 0;
11076
11077 #endif
11078
11079
11080     /* CRTL can be initialized past this point, but not before. */
11081 /*    DECC$CRTL_INIT(); */
11082
11083     return SS$_NORMAL;
11084 }
11085
11086 #ifdef __DECC
11087 /* DECC dependent attributes */
11088 #if __DECC_VER < 60560002
11089 #define relative
11090 #define not_executable
11091 #else
11092 #define relative ,rel
11093 #define not_executable ,noexe
11094 #endif
11095 #pragma nostandard
11096 #pragma extern_model save
11097 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11098 #endif
11099         const __align (LONGWORD) int spare[8] = {0};
11100 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11101 /*                        NOWRT, LONG */
11102 #ifdef __DECC
11103 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11104         nowrt,noshr relative not_executable
11105 #endif
11106 const long vms_cc_features = (const long)set_features;
11107
11108 /*
11109 ** Force a reference to LIB$INITIALIZE to ensure it
11110 ** exists in the image.
11111 */
11112 int lib$initialize(void);
11113 #ifdef __DECC
11114 #pragma extern_model strict_refdef
11115 #endif
11116     int lib_init_ref = (int) lib$initialize;
11117
11118 #ifdef __DECC
11119 #pragma extern_model restore
11120 #pragma standard
11121 #endif
11122
11123 /*  End of vms.c */