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