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 /* NAM$L_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
  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               memcpy(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) Perl_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,0) == 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           mp_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           mp_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(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:
1869         unix_status = EINTR;
1870         break;
1871     case SS$_BUFFEROVF:
1872         unix_status = E2BIG;
1873         break;
1874     case SS$_INSFMEM:
1875         unix_status = ENOMEM;
1876         break;
1877     case SS$_NOPRIV:
1878         unix_status = EPERM;
1879         break;
1880     case SS$_NOSUCHNODE:
1881     case SS$_UNREACHABLE:
1882         unix_status = ESRCH;
1883         break;
1884     case SS$_NONEXPR:
1885         unix_status = ECHILD;
1886         break;
1887     default:
1888         if ((facility == 0) && (msg_no < 8)) {
1889           /* These are not real VMS status codes so assume that they are
1890           ** already UNIX status codes
1891           */
1892           unix_status = msg_no;
1893           break;
1894         }
1895     }
1896   }
1897   else {
1898     /* Translate a POSIX exit code to a UNIX exit code */
1899     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1900         unix_status = (msg_no & 0x07F8) >> 3;
1901     }
1902     else {
1903
1904          /* Documented traditional behavior for handling VMS child exits */
1905         /*--------------------------------------------------------------*/
1906         if (child_flag != 0) {
1907
1908              /* Success / Informational return 0 */
1909             /*----------------------------------*/
1910             if (msg_no & STS$K_SUCCESS)
1911                 return 0;
1912
1913              /* Warning returns 1 */
1914             /*-------------------*/
1915             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1916                 return 1;
1917
1918              /* Everything else pass through the severity bits */
1919             /*------------------------------------------------*/
1920             return (msg_no & STS$M_SEVERITY);
1921         }
1922
1923          /* Normal VMS status to ERRNO mapping attempt */
1924         /*--------------------------------------------*/
1925         switch(msg_status) {
1926         /* case RMS$_EOF: */ /* End of File */
1927         case RMS$_FNF:  /* File Not Found */
1928         case RMS$_DNF:  /* Dir Not Found */
1929                 unix_status = ENOENT;
1930                 break;
1931         case RMS$_RNF:  /* Record Not Found */
1932                 unix_status = ESRCH;
1933                 break;
1934         case RMS$_DIR:
1935                 unix_status = ENOTDIR;
1936                 break;
1937         case RMS$_DEV:
1938                 unix_status = ENODEV;
1939                 break;
1940         case RMS$_IFI:
1941         case RMS$_FAC:
1942         case RMS$_ISI:
1943                 unix_status = EBADF;
1944                 break;
1945         case RMS$_FEX:
1946                 unix_status = EEXIST;
1947                 break;
1948         case RMS$_SYN:
1949         case RMS$_FNM:
1950         case LIB$_INVSTRDES:
1951         case LIB$_INVARG:
1952         case LIB$_NOSUCHSYM:
1953         case LIB$_INVSYMNAM:
1954         case DCL_IVVERB:
1955                 unix_status = EINVAL;
1956                 break;
1957         case CLI$_BUFOVF:
1958         case RMS$_RTB:
1959         case CLI$_TKNOVF:
1960         case CLI$_RSLOVF:
1961                 unix_status = E2BIG;
1962                 break;
1963         case RMS$_PRV:  /* No privilege */
1964         case RMS$_ACC:  /* ACP file access failed */
1965         case RMS$_WLK:  /* Device write locked */
1966                 unix_status = EACCES;
1967                 break;
1968         /* case RMS$_NMF: */  /* No more files */
1969         }
1970     }
1971   }
1972
1973   return unix_status;
1974 }
1975
1976 /* Try to guess at what VMS error status should go with a UNIX errno
1977  * value.  This is hard to do as there could be many possible VMS
1978  * error statuses that caused the errno value to be set.
1979  */
1980
1981 int Perl_unix_status_to_vms(int unix_status)
1982 {
1983 int test_unix_status;
1984
1985      /* Trivial cases first */
1986     /*---------------------*/
1987     if (unix_status == EVMSERR)
1988         return vaxc$errno;
1989
1990      /* Is vaxc$errno sane? */
1991     /*---------------------*/
1992     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1993     if (test_unix_status == unix_status)
1994         return vaxc$errno;
1995
1996      /* If way out of range, must be VMS code already */
1997     /*-----------------------------------------------*/
1998     if (unix_status > EVMSERR)
1999         return unix_status;
2000
2001      /* If out of range, punt */
2002     /*-----------------------*/
2003     if (unix_status > __ERRNO_MAX)
2004         return SS$_ABORT;
2005
2006
2007      /* Ok, now we have to do it the hard way. */
2008     /*----------------------------------------*/
2009     switch(unix_status) {
2010     case 0:     return SS$_NORMAL;
2011     case EPERM: return SS$_NOPRIV;
2012     case ENOENT: return SS$_NOSUCHOBJECT;
2013     case ESRCH: return SS$_UNREACHABLE;
2014     case EINTR: return SS$_ABORT;
2015     /* case EIO: */
2016     /* case ENXIO:  */
2017     case E2BIG: return SS$_BUFFEROVF;
2018     /* case ENOEXEC */
2019     case EBADF: return RMS$_IFI;
2020     case ECHILD: return SS$_NONEXPR;
2021     /* case EAGAIN */
2022     case ENOMEM: return SS$_INSFMEM;
2023     case EACCES: return SS$_FILACCERR;
2024     case EFAULT: return SS$_ACCVIO;
2025     /* case ENOTBLK */
2026     case EBUSY: SS$_DEVOFFLINE;
2027     case EEXIST: return RMS$_FEX;
2028     /* case EXDEV */
2029     case ENODEV: return SS$_NOSUCHDEV;
2030     case ENOTDIR: return RMS$_DIR;
2031     /* case EISDIR */
2032     case EINVAL: return SS$_INVARG;
2033     /* case ENFILE */
2034     /* case EMFILE */
2035     /* case ENOTTY */
2036     /* case ETXTBSY */
2037     /* case EFBIG */
2038     case ENOSPC: return SS$_DEVICEFULL;
2039     case ESPIPE: return LIB$_INVARG;
2040     /* case EROFS: */
2041     /* case EMLINK: */
2042     /* case EPIPE: */
2043     /* case EDOM */
2044     case ERANGE: return LIB$_INVARG;
2045     /* case EWOULDBLOCK */
2046     /* case EINPROGRESS */
2047     /* case EALREADY */
2048     /* case ENOTSOCK */
2049     /* case EDESTADDRREQ */
2050     /* case EMSGSIZE */
2051     /* case EPROTOTYPE */
2052     /* case ENOPROTOOPT */
2053     /* case EPROTONOSUPPORT */
2054     /* case ESOCKTNOSUPPORT */
2055     /* case EOPNOTSUPP */
2056     /* case EPFNOSUPPORT */
2057     /* case EAFNOSUPPORT */
2058     /* case EADDRINUSE */
2059     /* case EADDRNOTAVAIL */
2060     /* case ENETDOWN */
2061     /* case ENETUNREACH */
2062     /* case ENETRESET */
2063     /* case ECONNABORTED */
2064     /* case ECONNRESET */
2065     /* case ENOBUFS */
2066     /* case EISCONN */
2067     case ENOTCONN: return SS$_CLEARED;
2068     /* case ESHUTDOWN */
2069     /* case ETOOMANYREFS */
2070     /* case ETIMEDOUT */
2071     /* case ECONNREFUSED */
2072     /* case ELOOP */
2073     /* case ENAMETOOLONG */
2074     /* case EHOSTDOWN */
2075     /* case EHOSTUNREACH */
2076     /* case ENOTEMPTY */
2077     /* case EPROCLIM */
2078     /* case EUSERS  */
2079     /* case EDQUOT  */
2080     /* case ENOMSG  */
2081     /* case EIDRM */
2082     /* case EALIGN */
2083     /* case ESTALE */
2084     /* case EREMOTE */
2085     /* case ENOLCK */
2086     /* case ENOSYS */
2087     /* case EFTYPE */
2088     /* case ECANCELED */
2089     /* case EFAIL */
2090     /* case EINPROG */
2091     case ENOTSUP:
2092         return SS$_UNSUPPORTED;
2093     /* case EDEADLK */
2094     /* case ENWAIT */
2095     /* case EILSEQ */
2096     /* case EBADCAT */
2097     /* case EBADMSG */
2098     /* case EABANDONED */
2099     default:
2100         return SS$_ABORT; /* punt */
2101     }
2102
2103   return SS$_ABORT; /* Should not get here */
2104 }
2105
2106
2107 /* default piping mailbox size */
2108 #define PERL_BUFSIZ        512
2109
2110
2111 static void
2112 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2113 {
2114   unsigned long int mbxbufsiz;
2115   static unsigned long int syssize = 0;
2116   unsigned long int dviitm = DVI$_DEVNAM;
2117   char csize[LNM$C_NAMLENGTH+1];
2118   int sts;
2119
2120   if (!syssize) {
2121     unsigned long syiitm = SYI$_MAXBUF;
2122     /*
2123      * Get the SYSGEN parameter MAXBUF
2124      *
2125      * If the logical 'PERL_MBX_SIZE' is defined
2126      * use the value of the logical instead of PERL_BUFSIZ, but
2127      * keep the size between 128 and MAXBUF.
2128      *
2129      */
2130     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2131   }
2132
2133   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2134       mbxbufsiz = atoi(csize);
2135   } else {
2136       mbxbufsiz = PERL_BUFSIZ;
2137   }
2138   if (mbxbufsiz < 128) mbxbufsiz = 128;
2139   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2140
2141   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2142
2143   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2144   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2145
2146 }  /* end of create_mbx() */
2147
2148
2149 /*{{{  my_popen and my_pclose*/
2150
2151 typedef struct _iosb           IOSB;
2152 typedef struct _iosb*         pIOSB;
2153 typedef struct _pipe           Pipe;
2154 typedef struct _pipe*         pPipe;
2155 typedef struct pipe_details    Info;
2156 typedef struct pipe_details*  pInfo;
2157 typedef struct _srqp            RQE;
2158 typedef struct _srqp*          pRQE;
2159 typedef struct _tochildbuf      CBuf;
2160 typedef struct _tochildbuf*    pCBuf;
2161
2162 struct _iosb {
2163     unsigned short status;
2164     unsigned short count;
2165     unsigned long  dvispec;
2166 };
2167
2168 #pragma member_alignment save
2169 #pragma nomember_alignment quadword
2170 struct _srqp {          /* VMS self-relative queue entry */
2171     unsigned long qptr[2];
2172 };
2173 #pragma member_alignment restore
2174 static RQE  RQE_ZERO = {0,0};
2175
2176 struct _tochildbuf {
2177     RQE             q;
2178     int             eof;
2179     unsigned short  size;
2180     char            *buf;
2181 };
2182
2183 struct _pipe {
2184     RQE            free;
2185     RQE            wait;
2186     int            fd_out;
2187     unsigned short chan_in;
2188     unsigned short chan_out;
2189     char          *buf;
2190     unsigned int   bufsize;
2191     IOSB           iosb;
2192     IOSB           iosb2;
2193     int           *pipe_done;
2194     int            retry;
2195     int            type;
2196     int            shut_on_empty;
2197     int            need_wake;
2198     pPipe         *home;
2199     pInfo          info;
2200     pCBuf          curr;
2201     pCBuf          curr2;
2202 #if defined(PERL_IMPLICIT_CONTEXT)
2203     void            *thx;           /* Either a thread or an interpreter */
2204                                     /* pointer, depending on how we're built */
2205 #endif
2206 };
2207
2208
2209 struct pipe_details
2210 {
2211     pInfo           next;
2212     PerlIO *fp;  /* file pointer to pipe mailbox */
2213     int useFILE; /* using stdio, not perlio */
2214     int pid;   /* PID of subprocess */
2215     int mode;  /* == 'r' if pipe open for reading */
2216     int done;  /* subprocess has completed */
2217     int waiting; /* waiting for completion/closure */
2218     int             closing;        /* my_pclose is closing this pipe */
2219     unsigned long   completion;     /* termination status of subprocess */
2220     pPipe           in;             /* pipe in to sub */
2221     pPipe           out;            /* pipe out of sub */
2222     pPipe           err;            /* pipe of sub's sys$error */
2223     int             in_done;        /* true when in pipe finished */
2224     int             out_done;
2225     int             err_done;
2226 };
2227
2228 struct exit_control_block
2229 {
2230     struct exit_control_block *flink;
2231     unsigned long int   (*exit_routine)();
2232     unsigned long int arg_count;
2233     unsigned long int *status_address;
2234     unsigned long int exit_status;
2235 };
2236
2237 typedef struct _closed_pipes    Xpipe;
2238 typedef struct _closed_pipes*  pXpipe;
2239
2240 struct _closed_pipes {
2241     int             pid;            /* PID of subprocess */
2242     unsigned long   completion;     /* termination status of subprocess */
2243 };
2244 #define NKEEPCLOSED 50
2245 static Xpipe closed_list[NKEEPCLOSED];
2246 static int   closed_index = 0;
2247 static int   closed_num = 0;
2248
2249 #define RETRY_DELAY     "0 ::0.20"
2250 #define MAX_RETRY              50
2251
2252 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2253 static unsigned long mypid;
2254 static unsigned long delaytime[2];
2255
2256 static pInfo open_pipes = NULL;
2257 static $DESCRIPTOR(nl_desc, "NL:");
2258
2259 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2260
2261
2262
2263 static unsigned long int
2264 pipe_exit_routine(pTHX)
2265 {
2266     pInfo info;
2267     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2268     int sts, did_stuff, need_eof, j;
2269
2270     /*
2271         flush any pending i/o
2272     */
2273     info = open_pipes;
2274     while (info) {
2275         if (info->fp) {
2276            if (!info->useFILE)
2277                PerlIO_flush(info->fp);   /* first, flush data */
2278            else
2279                fflush((FILE *)info->fp);
2280         }
2281         info = info->next;
2282     }
2283
2284     /*
2285      next we try sending an EOF...ignore if doesn't work, make sure we
2286      don't hang
2287     */
2288     did_stuff = 0;
2289     info = open_pipes;
2290
2291     while (info) {
2292       int need_eof;
2293       _ckvmssts(sys$setast(0));
2294       if (info->in && !info->in->shut_on_empty) {
2295         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2296                           0, 0, 0, 0, 0, 0));
2297         info->waiting = 1;
2298         did_stuff = 1;
2299       }
2300       _ckvmssts(sys$setast(1));
2301       info = info->next;
2302     }
2303
2304     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2305
2306     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2307         int nwait = 0;
2308
2309         info = open_pipes;
2310         while (info) {
2311           _ckvmssts(sys$setast(0));
2312           if (info->waiting && info->done)
2313                 info->waiting = 0;
2314           nwait += info->waiting;
2315           _ckvmssts(sys$setast(1));
2316           info = info->next;
2317         }
2318         if (!nwait) break;
2319         sleep(1);
2320     }
2321
2322     did_stuff = 0;
2323     info = open_pipes;
2324     while (info) {
2325       _ckvmssts(sys$setast(0));
2326       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2327         sts = sys$forcex(&info->pid,0,&abort);
2328         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2329         did_stuff = 1;
2330       }
2331       _ckvmssts(sys$setast(1));
2332       info = info->next;
2333     }
2334
2335     /* again, wait for effect */
2336
2337     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2338         int nwait = 0;
2339
2340         info = open_pipes;
2341         while (info) {
2342           _ckvmssts(sys$setast(0));
2343           if (info->waiting && info->done)
2344                 info->waiting = 0;
2345           nwait += info->waiting;
2346           _ckvmssts(sys$setast(1));
2347           info = info->next;
2348         }
2349         if (!nwait) break;
2350         sleep(1);
2351     }
2352
2353     info = open_pipes;
2354     while (info) {
2355       _ckvmssts(sys$setast(0));
2356       if (!info->done) {  /* We tried to be nice . . . */
2357         sts = sys$delprc(&info->pid,0);
2358         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2359       }
2360       _ckvmssts(sys$setast(1));
2361       info = info->next;
2362     }
2363
2364     while(open_pipes) {
2365       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2366       else if (!(sts & 1)) retsts = sts;
2367     }
2368     return retsts;
2369 }
2370
2371 static struct exit_control_block pipe_exitblock =
2372        {(struct exit_control_block *) 0,
2373         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2374
2375 static void pipe_mbxtofd_ast(pPipe p);
2376 static void pipe_tochild1_ast(pPipe p);
2377 static void pipe_tochild2_ast(pPipe p);
2378
2379 static void
2380 popen_completion_ast(pInfo info)
2381 {
2382   pInfo i = open_pipes;
2383   int iss;
2384   int sts;
2385   pXpipe x;
2386
2387   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2388   closed_list[closed_index].pid = info->pid;
2389   closed_list[closed_index].completion = info->completion;
2390   closed_index++;
2391   if (closed_index == NKEEPCLOSED)
2392     closed_index = 0;
2393   closed_num++;
2394
2395   while (i) {
2396     if (i == info) break;
2397     i = i->next;
2398   }
2399   if (!i) return;       /* unlinked, probably freed too */
2400
2401   info->done = TRUE;
2402
2403 /*
2404     Writing to subprocess ...
2405             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2406
2407             chan_out may be waiting for "done" flag, or hung waiting
2408             for i/o completion to child...cancel the i/o.  This will
2409             put it into "snarf mode" (done but no EOF yet) that discards
2410             input.
2411
2412     Output from subprocess (stdout, stderr) needs to be flushed and
2413     shut down.   We try sending an EOF, but if the mbx is full the pipe
2414     routine should still catch the "shut_on_empty" flag, telling it to
2415     use immediate-style reads so that "mbx empty" -> EOF.
2416
2417
2418 */
2419   if (info->in && !info->in_done) {               /* only for mode=w */
2420         if (info->in->shut_on_empty && info->in->need_wake) {
2421             info->in->need_wake = FALSE;
2422             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2423         } else {
2424             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2425         }
2426   }
2427
2428   if (info->out && !info->out_done) {             /* were we also piping output? */
2429       info->out->shut_on_empty = TRUE;
2430       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2431       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2432       _ckvmssts_noperl(iss);
2433   }
2434
2435   if (info->err && !info->err_done) {        /* we were piping stderr */
2436         info->err->shut_on_empty = TRUE;
2437         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2438         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2439         _ckvmssts_noperl(iss);
2440   }
2441   _ckvmssts_noperl(sys$setef(pipe_ef));
2442
2443 }
2444
2445 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2446 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2447
2448 /*
2449     we actually differ from vmstrnenv since we use this to
2450     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2451     are pointing to the same thing
2452 */
2453
2454 static unsigned short
2455 popen_translate(pTHX_ char *logical, char *result)
2456 {
2457     int iss;
2458     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2459     $DESCRIPTOR(d_log,"");
2460     struct _il3 {
2461         unsigned short length;
2462         unsigned short code;
2463         char *         buffer_addr;
2464         unsigned short *retlenaddr;
2465     } itmlst[2];
2466     unsigned short l, ifi;
2467
2468     d_log.dsc$a_pointer = logical;
2469     d_log.dsc$w_length  = strlen(logical);
2470
2471     itmlst[0].code = LNM$_STRING;
2472     itmlst[0].length = 255;
2473     itmlst[0].buffer_addr = result;
2474     itmlst[0].retlenaddr = &l;
2475
2476     itmlst[1].code = 0;
2477     itmlst[1].length = 0;
2478     itmlst[1].buffer_addr = 0;
2479     itmlst[1].retlenaddr = 0;
2480
2481     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2482     if (iss == SS$_NOLOGNAM) {
2483         iss = SS$_NORMAL;
2484         l = 0;
2485     }
2486     if (!(iss&1)) lib$signal(iss);
2487     result[l] = '\0';
2488 /*
2489     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2490     strip it off and return the ifi, if any
2491 */
2492     ifi  = 0;
2493     if (result[0] == 0x1b && result[1] == 0x00) {
2494         memcpy(&ifi,result+2,2);
2495         strcpy(result,result+4);
2496     }
2497     return ifi;     /* this is the RMS internal file id */
2498 }
2499
2500 static void pipe_infromchild_ast(pPipe p);
2501
2502 /*
2503     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2504     inside an AST routine without worrying about reentrancy and which Perl
2505     memory allocator is being used.
2506
2507     We read data and queue up the buffers, then spit them out one at a
2508     time to the output mailbox when the output mailbox is ready for one.
2509
2510 */
2511 #define INITIAL_TOCHILDQUEUE  2
2512
2513 static pPipe
2514 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2515 {
2516     pPipe p;
2517     pCBuf b;
2518     char mbx1[64], mbx2[64];
2519     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2520                                       DSC$K_CLASS_S, mbx1},
2521                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2522                                       DSC$K_CLASS_S, mbx2};
2523     unsigned int dviitm = DVI$_DEVBUFSIZ;
2524     int j, n;
2525
2526     Newx(p, 1, Pipe);
2527
2528     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2529     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2530     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2531
2532     p->buf           = 0;
2533     p->shut_on_empty = FALSE;
2534     p->need_wake     = FALSE;
2535     p->type          = 0;
2536     p->retry         = 0;
2537     p->iosb.status   = SS$_NORMAL;
2538     p->iosb2.status  = SS$_NORMAL;
2539     p->free          = RQE_ZERO;
2540     p->wait          = RQE_ZERO;
2541     p->curr          = 0;
2542     p->curr2         = 0;
2543     p->info          = 0;
2544 #ifdef PERL_IMPLICIT_CONTEXT
2545     p->thx           = aTHX;
2546 #endif
2547
2548     n = sizeof(CBuf) + p->bufsize;
2549
2550     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2551         _ckvmssts(lib$get_vm(&n, &b));
2552         b->buf = (char *) b + sizeof(CBuf);
2553         _ckvmssts(lib$insqhi(b, &p->free));
2554     }
2555
2556     pipe_tochild2_ast(p);
2557     pipe_tochild1_ast(p);
2558     strcpy(wmbx, mbx1);
2559     strcpy(rmbx, mbx2);
2560     return p;
2561 }
2562
2563 /*  reads the MBX Perl is writing, and queues */
2564
2565 static void
2566 pipe_tochild1_ast(pPipe p)
2567 {
2568     pCBuf b = p->curr;
2569     int iss = p->iosb.status;
2570     int eof = (iss == SS$_ENDOFFILE);
2571     int sts;
2572 #ifdef PERL_IMPLICIT_CONTEXT
2573     pTHX = p->thx;
2574 #endif
2575
2576     if (p->retry) {
2577         if (eof) {
2578             p->shut_on_empty = TRUE;
2579             b->eof     = TRUE;
2580             _ckvmssts(sys$dassgn(p->chan_in));
2581         } else  {
2582             _ckvmssts(iss);
2583         }
2584
2585         b->eof  = eof;
2586         b->size = p->iosb.count;
2587         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2588         if (p->need_wake) {
2589             p->need_wake = FALSE;
2590             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2591         }
2592     } else {
2593         p->retry = 1;   /* initial call */
2594     }
2595
2596     if (eof) {                  /* flush the free queue, return when done */
2597         int n = sizeof(CBuf) + p->bufsize;
2598         while (1) {
2599             iss = lib$remqti(&p->free, &b);
2600             if (iss == LIB$_QUEWASEMP) return;
2601             _ckvmssts(iss);
2602             _ckvmssts(lib$free_vm(&n, &b));
2603         }
2604     }
2605
2606     iss = lib$remqti(&p->free, &b);
2607     if (iss == LIB$_QUEWASEMP) {
2608         int n = sizeof(CBuf) + p->bufsize;
2609         _ckvmssts(lib$get_vm(&n, &b));
2610         b->buf = (char *) b + sizeof(CBuf);
2611     } else {
2612        _ckvmssts(iss);
2613     }
2614
2615     p->curr = b;
2616     iss = sys$qio(0,p->chan_in,
2617              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2618              &p->iosb,
2619              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2620     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2621     _ckvmssts(iss);
2622 }
2623
2624
2625 /* writes queued buffers to output, waits for each to complete before
2626    doing the next */
2627
2628 static void
2629 pipe_tochild2_ast(pPipe p)
2630 {
2631     pCBuf b = p->curr2;
2632     int iss = p->iosb2.status;
2633     int n = sizeof(CBuf) + p->bufsize;
2634     int done = (p->info && p->info->done) ||
2635               iss == SS$_CANCEL || iss == SS$_ABORT;
2636 #if defined(PERL_IMPLICIT_CONTEXT)
2637     pTHX = p->thx;
2638 #endif
2639
2640     do {
2641         if (p->type) {         /* type=1 has old buffer, dispose */
2642             if (p->shut_on_empty) {
2643                 _ckvmssts(lib$free_vm(&n, &b));
2644             } else {
2645                 _ckvmssts(lib$insqhi(b, &p->free));
2646             }
2647             p->type = 0;
2648         }
2649
2650         iss = lib$remqti(&p->wait, &b);
2651         if (iss == LIB$_QUEWASEMP) {
2652             if (p->shut_on_empty) {
2653                 if (done) {
2654                     _ckvmssts(sys$dassgn(p->chan_out));
2655                     *p->pipe_done = TRUE;
2656                     _ckvmssts(sys$setef(pipe_ef));
2657                 } else {
2658                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2659                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2660                 }
2661                 return;
2662             }
2663             p->need_wake = TRUE;
2664             return;
2665         }
2666         _ckvmssts(iss);
2667         p->type = 1;
2668     } while (done);
2669
2670
2671     p->curr2 = b;
2672     if (b->eof) {
2673         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2674             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2675     } else {
2676         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2677             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2678     }
2679
2680     return;
2681
2682 }
2683
2684
2685 static pPipe
2686 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2687 {
2688     pPipe p;
2689     char mbx1[64], mbx2[64];
2690     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2691                                       DSC$K_CLASS_S, mbx1},
2692                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2693                                       DSC$K_CLASS_S, mbx2};
2694     unsigned int dviitm = DVI$_DEVBUFSIZ;
2695
2696     Newx(p, 1, Pipe);
2697     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2698     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2699
2700     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2701     Newx(p->buf, p->bufsize, char);
2702     p->shut_on_empty = FALSE;
2703     p->info   = 0;
2704     p->type   = 0;
2705     p->iosb.status = SS$_NORMAL;
2706 #if defined(PERL_IMPLICIT_CONTEXT)
2707     p->thx = aTHX;
2708 #endif
2709     pipe_infromchild_ast(p);
2710
2711     strcpy(wmbx, mbx1);
2712     strcpy(rmbx, mbx2);
2713     return p;
2714 }
2715
2716 static void
2717 pipe_infromchild_ast(pPipe p)
2718 {
2719     int iss = p->iosb.status;
2720     int eof = (iss == SS$_ENDOFFILE);
2721     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2722     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2723 #if defined(PERL_IMPLICIT_CONTEXT)
2724     pTHX = p->thx;
2725 #endif
2726
2727     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2728         _ckvmssts(sys$dassgn(p->chan_out));
2729         p->chan_out = 0;
2730     }
2731
2732     /* read completed:
2733             input shutdown if EOF from self (done or shut_on_empty)
2734             output shutdown if closing flag set (my_pclose)
2735             send data/eof from child or eof from self
2736             otherwise, re-read (snarf of data from child)
2737     */
2738
2739     if (p->type == 1) {
2740         p->type = 0;
2741         if (myeof && p->chan_in) {                  /* input shutdown */
2742             _ckvmssts(sys$dassgn(p->chan_in));
2743             p->chan_in = 0;
2744         }
2745
2746         if (p->chan_out) {
2747             if (myeof || kideof) {      /* pass EOF to parent */
2748                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2749                               pipe_infromchild_ast, p,
2750                               0, 0, 0, 0, 0, 0));
2751                 return;
2752             } else if (eof) {       /* eat EOF --- fall through to read*/
2753
2754             } else {                /* transmit data */
2755                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2756                               pipe_infromchild_ast,p,
2757                               p->buf, p->iosb.count, 0, 0, 0, 0));
2758                 return;
2759             }
2760         }
2761     }
2762
2763     /*  everything shut? flag as done */
2764
2765     if (!p->chan_in && !p->chan_out) {
2766         *p->pipe_done = TRUE;
2767         _ckvmssts(sys$setef(pipe_ef));
2768         return;
2769     }
2770
2771     /* write completed (or read, if snarfing from child)
2772             if still have input active,
2773                queue read...immediate mode if shut_on_empty so we get EOF if empty
2774             otherwise,
2775                check if Perl reading, generate EOFs as needed
2776     */
2777
2778     if (p->type == 0) {
2779         p->type = 1;
2780         if (p->chan_in) {
2781             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2782                           pipe_infromchild_ast,p,
2783                           p->buf, p->bufsize, 0, 0, 0, 0);
2784             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2785             _ckvmssts(iss);
2786         } else {           /* send EOFs for extra reads */
2787             p->iosb.status = SS$_ENDOFFILE;
2788             p->iosb.dvispec = 0;
2789             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2790                       0, 0, 0,
2791                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2792         }
2793     }
2794 }
2795
2796 static pPipe
2797 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2798 {
2799     pPipe p;
2800     char mbx[64];
2801     unsigned long dviitm = DVI$_DEVBUFSIZ;
2802     struct stat s;
2803     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2804                                       DSC$K_CLASS_S, mbx};
2805
2806     /* things like terminals and mbx's don't need this filter */
2807     if (fd && fstat(fd,&s) == 0) {
2808         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2809         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2810                                          DSC$K_CLASS_S, s.st_dev};
2811
2812         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2813         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2814             strcpy(out, s.st_dev);
2815             return 0;
2816         }
2817     }
2818
2819     Newx(p, 1, Pipe);
2820     p->fd_out = dup(fd);
2821     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2822     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2823     Newx(p->buf, p->bufsize+1, char);
2824     p->shut_on_empty = FALSE;
2825     p->retry = 0;
2826     p->info  = 0;
2827     strcpy(out, mbx);
2828
2829     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2830                   pipe_mbxtofd_ast, p,
2831                   p->buf, p->bufsize, 0, 0, 0, 0));
2832
2833     return p;
2834 }
2835
2836 static void
2837 pipe_mbxtofd_ast(pPipe p)
2838 {
2839     int iss = p->iosb.status;
2840     int done = p->info->done;
2841     int iss2;
2842     int eof = (iss == SS$_ENDOFFILE);
2843     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2844     int err = !(iss&1) && !eof;
2845 #if defined(PERL_IMPLICIT_CONTEXT)
2846     pTHX = p->thx;
2847 #endif
2848
2849     if (done && myeof) {               /* end piping */
2850         close(p->fd_out);
2851         sys$dassgn(p->chan_in);
2852         *p->pipe_done = TRUE;
2853         _ckvmssts(sys$setef(pipe_ef));
2854         return;
2855     }
2856
2857     if (!err && !eof) {             /* good data to send to file */
2858         p->buf[p->iosb.count] = '\n';
2859         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2860         if (iss2 < 0) {
2861             p->retry++;
2862             if (p->retry < MAX_RETRY) {
2863                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2864                 return;
2865             }
2866         }
2867         p->retry = 0;
2868     } else if (err) {
2869         _ckvmssts(iss);
2870     }
2871
2872
2873     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2874           pipe_mbxtofd_ast, p,
2875           p->buf, p->bufsize, 0, 0, 0, 0);
2876     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2877     _ckvmssts(iss);
2878 }
2879
2880
2881 typedef struct _pipeloc     PLOC;
2882 typedef struct _pipeloc*   pPLOC;
2883
2884 struct _pipeloc {
2885     pPLOC   next;
2886     char    dir[NAM$C_MAXRSS+1];
2887 };
2888 static pPLOC  head_PLOC = 0;
2889
2890 void
2891 free_pipelocs(pTHX_ void *head)
2892 {
2893     pPLOC p, pnext;
2894     pPLOC *pHead = (pPLOC *)head;
2895
2896     p = *pHead;
2897     while (p) {
2898         pnext = p->next;
2899         Safefree(p);
2900         p = pnext;
2901     }
2902     *pHead = 0;
2903 }
2904
2905 static void
2906 store_pipelocs(pTHX)
2907 {
2908     int    i;
2909     pPLOC  p;
2910     AV    *av = 0;
2911     SV    *dirsv;
2912     GV    *gv;
2913     char  *dir, *x;
2914     char  *unixdir;
2915     char  temp[NAM$C_MAXRSS+1];
2916     STRLEN n_a;
2917
2918     if (head_PLOC)
2919         free_pipelocs(aTHX_ &head_PLOC);
2920
2921 /*  the . directory from @INC comes last */
2922
2923     Newx(p,1,PLOC);
2924     p->next = head_PLOC;
2925     head_PLOC = p;
2926     strcpy(p->dir,"./");
2927
2928 /*  get the directory from $^X */
2929
2930 #ifdef PERL_IMPLICIT_CONTEXT
2931     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2932 #else
2933     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2934 #endif
2935         strcpy(temp, PL_origargv[0]);
2936         x = strrchr(temp,']');
2937         if (x == NULL) {
2938         x = strrchr(temp,'>');
2939           if (x == NULL) {
2940             /* It could be a UNIX path */
2941             x = strrchr(temp,'/');
2942           }
2943         }
2944         if (x)
2945           x[1] = '\0';
2946         else {
2947           /* Got a bare name, so use default directory */
2948           temp[0] = '.';
2949           temp[1] = '\0';
2950         }
2951
2952         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2953             Newx(p,1,PLOC);
2954             p->next = head_PLOC;
2955             head_PLOC = p;
2956             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2957             p->dir[NAM$C_MAXRSS] = '\0';
2958         }
2959     }
2960
2961 /*  reverse order of @INC entries, skip "." since entered above */
2962
2963 #ifdef PERL_IMPLICIT_CONTEXT
2964     if (aTHX)
2965 #endif
2966     if (PL_incgv) av = GvAVn(PL_incgv);
2967
2968     for (i = 0; av && i <= AvFILL(av); i++) {
2969         dirsv = *av_fetch(av,i,TRUE);
2970
2971         if (SvROK(dirsv)) continue;
2972         dir = SvPVx(dirsv,n_a);
2973         if (strcmp(dir,".") == 0) continue;
2974         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2975             continue;
2976
2977         Newx(p,1,PLOC);
2978         p->next = head_PLOC;
2979         head_PLOC = p;
2980         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2981         p->dir[NAM$C_MAXRSS] = '\0';
2982     }
2983
2984 /* most likely spot (ARCHLIB) put first in the list */
2985
2986 #ifdef ARCHLIB_EXP
2987     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2988         Newx(p,1,PLOC);
2989         p->next = head_PLOC;
2990         head_PLOC = p;
2991         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2992         p->dir[NAM$C_MAXRSS] = '\0';
2993     }
2994 #endif
2995 }
2996
2997
2998 static char *
2999 find_vmspipe(pTHX)
3000 {
3001     static int   vmspipe_file_status = 0;
3002     static char  vmspipe_file[NAM$C_MAXRSS+1];
3003
3004     /* already found? Check and use ... need read+execute permission */
3005
3006     if (vmspipe_file_status == 1) {
3007         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3008          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3009             return vmspipe_file;
3010         }
3011         vmspipe_file_status = 0;
3012     }
3013
3014     /* scan through stored @INC, $^X */
3015
3016     if (vmspipe_file_status == 0) {
3017         char file[NAM$C_MAXRSS+1];
3018         pPLOC  p = head_PLOC;
3019
3020         while (p) {
3021             strcpy(file, p->dir);
3022             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3023             file[NAM$C_MAXRSS] = '\0';
3024             p = p->next;
3025
3026             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3027
3028             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3029              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3030                 vmspipe_file_status = 1;
3031                 return vmspipe_file;
3032             }
3033         }
3034         vmspipe_file_status = -1;   /* failed, use tempfiles */
3035     }
3036
3037     return 0;
3038 }
3039
3040 static FILE *
3041 vmspipe_tempfile(pTHX)
3042 {
3043     char file[NAM$C_MAXRSS+1];
3044     FILE *fp;
3045     static int index = 0;
3046     Stat_t s0, s1;
3047     int cmp_result;
3048
3049     /* create a tempfile */
3050
3051     /* we can't go from   W, shr=get to  R, shr=get without
3052        an intermediate vulnerable state, so don't bother trying...
3053
3054        and lib$spawn doesn't shr=put, so have to close the write
3055
3056        So... match up the creation date/time and the FID to
3057        make sure we're dealing with the same file
3058
3059     */
3060
3061     index++;
3062     if (!decc_filename_unix_only) {
3063       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3064       fp = fopen(file,"w");
3065       if (!fp) {
3066         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3067         fp = fopen(file,"w");
3068         if (!fp) {
3069             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3070             fp = fopen(file,"w");
3071         }
3072       }
3073      }
3074      else {
3075       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3076       fp = fopen(file,"w");
3077       if (!fp) {
3078         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3079         fp = fopen(file,"w");
3080         if (!fp) {
3081           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3082           fp = fopen(file,"w");
3083         }
3084       }
3085     }
3086     if (!fp) return 0;  /* we're hosed */
3087
3088     fprintf(fp,"$! 'f$verify(0)'\n");
3089     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3090     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3091     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3092     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3093     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3094     fprintf(fp,"$ perl_del    = \"delete\"\n");
3095     fprintf(fp,"$ pif         = \"if\"\n");
3096     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3097     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3098     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3099     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3100     fprintf(fp,"$!  --- build command line to get max possible length\n");
3101     fprintf(fp,"$c=perl_popen_cmd0\n");
3102     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3103     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3104     fprintf(fp,"$x=perl_popen_cmd3\n");
3105     fprintf(fp,"$c=c+x\n");
3106     fprintf(fp,"$ perl_on\n");
3107     fprintf(fp,"$ 'c'\n");
3108     fprintf(fp,"$ perl_status = $STATUS\n");
3109     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3110     fprintf(fp,"$ perl_exit 'perl_status'\n");
3111     fsync(fileno(fp));
3112
3113     fgetname(fp, file, 1);
3114     fstat(fileno(fp), (struct stat *)&s0);
3115     fclose(fp);
3116
3117     if (decc_filename_unix_only)
3118         do_tounixspec(file, file, 0);
3119     fp = fopen(file,"r","shr=get");
3120     if (!fp) return 0;
3121     fstat(fileno(fp), (struct stat *)&s1);
3122
3123     #if defined(_USE_STD_STAT)
3124       cmp_result = s0.st_ino != s1.st_ino;
3125     #else
3126       cmp_result = memcmp(&s0.st_ino, &s1.st_ino, 6);
3127     #endif
3128     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3129         fclose(fp);
3130         return 0;
3131     }
3132
3133     return fp;
3134 }
3135
3136
3137
3138 static PerlIO *
3139 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3140 {
3141     static int handler_set_up = FALSE;
3142     unsigned long int sts, flags = CLI$M_NOWAIT;
3143     /* The use of a GLOBAL table (as was done previously) rendered
3144      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3145      * environment.  Hence we've switched to LOCAL symbol table.
3146      */
3147     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3148     int j, wait = 0;
3149     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3150     char in[512], out[512], err[512], mbx[512];
3151     FILE *tpipe = 0;
3152     char tfilebuf[NAM$C_MAXRSS+1];
3153     pInfo info;
3154     char cmd_sym_name[20];
3155     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3156                                       DSC$K_CLASS_S, symbol};
3157     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3158                                       DSC$K_CLASS_S, 0};
3159     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3160                                       DSC$K_CLASS_S, cmd_sym_name};
3161     struct dsc$descriptor_s *vmscmd;
3162     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3163     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3164     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3165
3166     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3167
3168     /* once-per-program initialization...
3169        note that the SETAST calls and the dual test of pipe_ef
3170        makes sure that only the FIRST thread through here does
3171        the initialization...all other threads wait until it's
3172        done.
3173
3174        Yeah, uglier than a pthread call, it's got all the stuff inline
3175        rather than in a separate routine.
3176     */
3177
3178     if (!pipe_ef) {
3179         _ckvmssts(sys$setast(0));
3180         if (!pipe_ef) {
3181             unsigned long int pidcode = JPI$_PID;
3182             $DESCRIPTOR(d_delay, RETRY_DELAY);
3183             _ckvmssts(lib$get_ef(&pipe_ef));
3184             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3185             _ckvmssts(sys$bintim(&d_delay, delaytime));
3186         }
3187         if (!handler_set_up) {
3188           _ckvmssts(sys$dclexh(&pipe_exitblock));
3189           handler_set_up = TRUE;
3190         }
3191         _ckvmssts(sys$setast(1));
3192     }
3193
3194     /* see if we can find a VMSPIPE.COM */
3195
3196     tfilebuf[0] = '@';
3197     vmspipe = find_vmspipe(aTHX);
3198     if (vmspipe) {
3199         strcpy(tfilebuf+1,vmspipe);
3200     } else {        /* uh, oh...we're in tempfile hell */
3201         tpipe = vmspipe_tempfile(aTHX);
3202         if (!tpipe) {       /* a fish popular in Boston */
3203             if (ckWARN(WARN_PIPE)) {
3204                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3205             }
3206         return Nullfp;
3207         }
3208         fgetname(tpipe,tfilebuf+1,1);
3209     }
3210     vmspipedsc.dsc$a_pointer = tfilebuf;
3211     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3212
3213     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3214     if (!(sts & 1)) {
3215       switch (sts) {
3216         case RMS$_FNF:  case RMS$_DNF:
3217           set_errno(ENOENT); break;
3218         case RMS$_DIR:
3219           set_errno(ENOTDIR); break;
3220         case RMS$_DEV:
3221           set_errno(ENODEV); break;
3222         case RMS$_PRV:
3223           set_errno(EACCES); break;
3224         case RMS$_SYN:
3225           set_errno(EINVAL); break;
3226         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3227           set_errno(E2BIG); break;
3228         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3229           _ckvmssts(sts); /* fall through */
3230         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3231           set_errno(EVMSERR);
3232       }
3233       set_vaxc_errno(sts);
3234       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3235         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3236       }
3237       *psts = sts;
3238       return Nullfp;
3239     }
3240     Newx(info,1,Info);
3241
3242     strcpy(mode,in_mode);
3243     info->mode = *mode;
3244     info->done = FALSE;
3245     info->completion = 0;
3246     info->closing    = FALSE;
3247     info->in         = 0;
3248     info->out        = 0;
3249     info->err        = 0;
3250     info->fp         = Nullfp;
3251     info->useFILE    = 0;
3252     info->waiting    = 0;
3253     info->in_done    = TRUE;
3254     info->out_done   = TRUE;
3255     info->err_done   = TRUE;
3256     in[0] = out[0] = err[0] = '\0';
3257
3258     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3259         info->useFILE = 1;
3260         strcpy(p,p+1);
3261     }
3262     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3263         wait = 1;
3264         strcpy(p,p+1);
3265     }
3266
3267     if (*mode == 'r') {             /* piping from subroutine */
3268
3269         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3270         if (info->out) {
3271             info->out->pipe_done = &info->out_done;
3272             info->out_done = FALSE;
3273             info->out->info = info;
3274         }
3275         if (!info->useFILE) {
3276         info->fp  = PerlIO_open(mbx, mode);
3277         } else {
3278             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3279             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3280         }
3281
3282         if (!info->fp && info->out) {
3283             sys$cancel(info->out->chan_out);
3284
3285             while (!info->out_done) {
3286                 int done;
3287                 _ckvmssts(sys$setast(0));
3288                 done = info->out_done;
3289                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3290                 _ckvmssts(sys$setast(1));
3291                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3292             }
3293
3294             if (info->out->buf) Safefree(info->out->buf);
3295             Safefree(info->out);
3296             Safefree(info);
3297             *psts = RMS$_FNF;
3298             return Nullfp;
3299         }
3300
3301         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3302         if (info->err) {
3303             info->err->pipe_done = &info->err_done;
3304             info->err_done = FALSE;
3305             info->err->info = info;
3306         }
3307
3308     } else if (*mode == 'w') {      /* piping to subroutine */
3309
3310         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3311         if (info->out) {
3312             info->out->pipe_done = &info->out_done;
3313             info->out_done = FALSE;
3314             info->out->info = info;
3315         }
3316
3317         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3318         if (info->err) {
3319             info->err->pipe_done = &info->err_done;
3320             info->err_done = FALSE;
3321             info->err->info = info;
3322         }
3323
3324         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3325         if (!info->useFILE) {
3326         info->fp  = PerlIO_open(mbx, mode);
3327         } else {
3328             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3329             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3330         }
3331
3332         if (info->in) {
3333             info->in->pipe_done = &info->in_done;
3334             info->in_done = FALSE;
3335             info->in->info = info;
3336         }
3337
3338         /* error cleanup */
3339         if (!info->fp && info->in) {
3340             info->done = TRUE;
3341             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3342                               0, 0, 0, 0, 0, 0, 0, 0));
3343
3344             while (!info->in_done) {
3345                 int done;
3346                 _ckvmssts(sys$setast(0));
3347                 done = info->in_done;
3348                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3349                 _ckvmssts(sys$setast(1));
3350                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3351             }
3352
3353             if (info->in->buf) Safefree(info->in->buf);
3354             Safefree(info->in);
3355             Safefree(info);
3356             *psts = RMS$_FNF;
3357             return Nullfp;
3358         }
3359
3360
3361     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3362         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3363         if (info->out) {
3364             info->out->pipe_done = &info->out_done;
3365             info->out_done = FALSE;
3366             info->out->info = info;
3367         }
3368
3369         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3370         if (info->err) {
3371             info->err->pipe_done = &info->err_done;
3372             info->err_done = FALSE;
3373             info->err->info = info;
3374         }
3375     }
3376
3377     symbol[MAX_DCL_SYMBOL] = '\0';
3378
3379     strncpy(symbol, in, MAX_DCL_SYMBOL);
3380     d_symbol.dsc$w_length = strlen(symbol);
3381     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3382
3383     strncpy(symbol, err, MAX_DCL_SYMBOL);
3384     d_symbol.dsc$w_length = strlen(symbol);
3385     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3386
3387     strncpy(symbol, out, MAX_DCL_SYMBOL);
3388     d_symbol.dsc$w_length = strlen(symbol);
3389     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3390
3391     p = vmscmd->dsc$a_pointer;
3392     while (*p && *p != '\n') p++;
3393     *p = '\0';                                  /* truncate on \n */
3394     p = vmscmd->dsc$a_pointer;
3395     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3396     if (*p == '$') p++;                         /* remove leading $ */
3397     while (*p == ' ' || *p == '\t') p++;
3398
3399     for (j = 0; j < 4; j++) {
3400         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3401         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3402
3403     strncpy(symbol, p, MAX_DCL_SYMBOL);
3404     d_symbol.dsc$w_length = strlen(symbol);
3405     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3406
3407         if (strlen(p) > MAX_DCL_SYMBOL) {
3408             p += MAX_DCL_SYMBOL;
3409         } else {
3410             p += strlen(p);
3411         }
3412     }
3413     _ckvmssts(sys$setast(0));
3414     info->next=open_pipes;  /* prepend to list */
3415     open_pipes=info;
3416     _ckvmssts(sys$setast(1));
3417     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3418      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3419      * have SYS$COMMAND if we need it.
3420      */
3421     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3422                       0, &info->pid, &info->completion,
3423                       0, popen_completion_ast,info,0,0,0));
3424
3425     /* if we were using a tempfile, close it now */
3426
3427     if (tpipe) fclose(tpipe);
3428
3429     /* once the subprocess is spawned, it has copied the symbols and
3430        we can get rid of ours */
3431
3432     for (j = 0; j < 4; j++) {
3433         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3434         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3435     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3436     }
3437     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3438     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3439     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3440     vms_execfree(vmscmd);
3441
3442 #ifdef PERL_IMPLICIT_CONTEXT
3443     if (aTHX)
3444 #endif
3445     PL_forkprocess = info->pid;
3446
3447     if (wait) {
3448          int done = 0;
3449          while (!done) {
3450              _ckvmssts(sys$setast(0));
3451              done = info->done;
3452              if (!done) _ckvmssts(sys$clref(pipe_ef));
3453              _ckvmssts(sys$setast(1));
3454              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3455          }
3456         *psts = info->completion;
3457 /* Caller thinks it is open and tries to close it. */
3458 /* This causes some problems, as it changes the error status */
3459 /*        my_pclose(info->fp); */
3460     } else {
3461         *psts = SS$_NORMAL;
3462     }
3463     return info->fp;
3464 }  /* end of safe_popen */
3465
3466
3467 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3468 PerlIO *
3469 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3470 {
3471     int sts;
3472     TAINT_ENV();
3473     TAINT_PROPER("popen");
3474     PERL_FLUSHALL_FOR_CHILD;
3475     return safe_popen(aTHX_ cmd,mode,&sts);
3476 }
3477
3478 /*}}}*/
3479
3480 /*{{{  I32 my_pclose(PerlIO *fp)*/
3481 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3482 {
3483     pInfo info, last = NULL;
3484     unsigned long int retsts;
3485     int done, iss;
3486
3487     for (info = open_pipes; info != NULL; last = info, info = info->next)
3488         if (info->fp == fp) break;
3489
3490     if (info == NULL) {  /* no such pipe open */
3491       set_errno(ECHILD); /* quoth POSIX */
3492       set_vaxc_errno(SS$_NONEXPR);
3493       return -1;
3494     }
3495
3496     /* If we were writing to a subprocess, insure that someone reading from
3497      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3498      * produce an EOF record in the mailbox.
3499      *
3500      *  well, at least sometimes it *does*, so we have to watch out for
3501      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3502      */
3503      if (info->fp) {
3504         if (!info->useFILE)
3505      PerlIO_flush(info->fp);   /* first, flush data */
3506         else
3507             fflush((FILE *)info->fp);
3508     }
3509
3510     _ckvmssts(sys$setast(0));
3511      info->closing = TRUE;
3512      done = info->done && info->in_done && info->out_done && info->err_done;
3513      /* hanging on write to Perl's input? cancel it */
3514      if (info->mode == 'r' && info->out && !info->out_done) {
3515         if (info->out->chan_out) {
3516             _ckvmssts(sys$cancel(info->out->chan_out));
3517             if (!info->out->chan_in) {   /* EOF generation, need AST */
3518                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3519             }
3520         }
3521      }
3522      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3523          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3524                            0, 0, 0, 0, 0, 0));
3525     _ckvmssts(sys$setast(1));
3526     if (info->fp) {
3527      if (!info->useFILE)
3528     PerlIO_close(info->fp);
3529      else
3530         fclose((FILE *)info->fp);
3531     }
3532      /*
3533         we have to wait until subprocess completes, but ALSO wait until all
3534         the i/o completes...otherwise we'll be freeing the "info" structure
3535         that the i/o ASTs could still be using...
3536      */
3537
3538      while (!done) {
3539          _ckvmssts(sys$setast(0));
3540          done = info->done && info->in_done && info->out_done && info->err_done;
3541          if (!done) _ckvmssts(sys$clref(pipe_ef));
3542          _ckvmssts(sys$setast(1));
3543          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3544      }
3545      retsts = info->completion;
3546
3547     /* remove from list of open pipes */
3548     _ckvmssts(sys$setast(0));
3549     if (last) last->next = info->next;
3550     else open_pipes = info->next;
3551     _ckvmssts(sys$setast(1));
3552
3553     /* free buffers and structures */
3554
3555     if (info->in) {
3556         if (info->in->buf) Safefree(info->in->buf);
3557         Safefree(info->in);
3558     }
3559     if (info->out) {
3560         if (info->out->buf) Safefree(info->out->buf);
3561         Safefree(info->out);
3562     }
3563     if (info->err) {
3564         if (info->err->buf) Safefree(info->err->buf);
3565         Safefree(info->err);
3566     }
3567     Safefree(info);
3568
3569     return retsts;
3570
3571 }  /* end of my_pclose() */
3572
3573 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3574   /* Roll our own prototype because we want this regardless of whether
3575    * _VMS_WAIT is defined.
3576    */
3577   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3578 #endif
3579 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3580    created with popen(); otherwise partially emulate waitpid() unless
3581    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3582    Also check processes not considered by the CRTL waitpid().
3583  */
3584 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3585 Pid_t
3586 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3587 {
3588     pInfo info;
3589     int done;
3590     int sts;
3591     int j;
3592
3593     if (statusp) *statusp = 0;
3594
3595     for (info = open_pipes; info != NULL; info = info->next)
3596         if (info->pid == pid) break;
3597
3598     if (info != NULL) {  /* we know about this child */
3599       while (!info->done) {
3600           _ckvmssts(sys$setast(0));
3601           done = info->done;
3602           if (!done) _ckvmssts(sys$clref(pipe_ef));
3603           _ckvmssts(sys$setast(1));
3604           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3605       }
3606
3607       if (statusp) *statusp = info->completion;
3608       return pid;
3609     }
3610
3611     /* child that already terminated? */
3612
3613     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3614         if (closed_list[j].pid == pid) {
3615             if (statusp) *statusp = closed_list[j].completion;
3616             return pid;
3617         }
3618     }
3619
3620     /* fall through if this child is not one of our own pipe children */
3621
3622 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3623
3624       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3625        * in 7.2 did we get a version that fills in the VMS completion
3626        * status as Perl has always tried to do.
3627        */
3628
3629       sts = __vms_waitpid( pid, statusp, flags );
3630
3631       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3632          return sts;
3633
3634       /* If the real waitpid tells us the child does not exist, we
3635        * fall through here to implement waiting for a child that
3636        * was created by some means other than exec() (say, spawned
3637        * from DCL) or to wait for a process that is not a subprocess
3638        * of the current process.
3639        */
3640
3641 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3642
3643     {
3644       $DESCRIPTOR(intdsc,"0 00:00:01");
3645       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3646       unsigned long int pidcode = JPI$_PID, mypid;
3647       unsigned long int interval[2];
3648       unsigned int jpi_iosb[2];
3649       struct itmlst_3 jpilist[2] = {
3650           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3651           {                      0,         0,                 0, 0}
3652       };
3653
3654       if (pid <= 0) {
3655         /* Sorry folks, we don't presently implement rooting around for
3656            the first child we can find, and we definitely don't want to
3657            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3658          */
3659         set_errno(ENOTSUP);
3660         return -1;
3661       }
3662
3663       /* Get the owner of the child so I can warn if it's not mine. If the
3664        * process doesn't exist or I don't have the privs to look at it,
3665        * I can go home early.
3666        */
3667       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3668       if (sts & 1) sts = jpi_iosb[0];
3669       if (!(sts & 1)) {
3670         switch (sts) {
3671             case SS$_NONEXPR:
3672                 set_errno(ECHILD);
3673                 break;
3674             case SS$_NOPRIV:
3675                 set_errno(EACCES);
3676                 break;
3677             default:
3678                 _ckvmssts(sts);
3679         }
3680         set_vaxc_errno(sts);
3681         return -1;
3682       }
3683
3684       if (ckWARN(WARN_EXEC)) {
3685         /* remind folks they are asking for non-standard waitpid behavior */
3686         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3687         if (ownerpid != mypid)
3688           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3689                       "waitpid: process %x is not a child of process %x",
3690                       pid,mypid);
3691       }
3692
3693       /* simply check on it once a second until it's not there anymore. */
3694
3695       _ckvmssts(sys$bintim(&intdsc,interval));
3696       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3697             _ckvmssts(sys$schdwk(0,0,interval,0));
3698             _ckvmssts(sys$hiber());
3699       }
3700       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3701
3702       _ckvmssts(sts);
3703       return pid;
3704     }
3705 }  /* end of waitpid() */
3706 /*}}}*/
3707 /*}}}*/
3708 /*}}}*/
3709
3710 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3711 char *
3712 my_gconvert(double val, int ndig, int trail, char *buf)
3713 {
3714   static char __gcvtbuf[DBL_DIG+1];
3715   char *loc;
3716
3717   loc = buf ? buf : __gcvtbuf;
3718
3719 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3720   if (val < 1) {
3721     sprintf(loc,"%.*g",ndig,val);
3722     return loc;
3723   }
3724 #endif
3725
3726   if (val) {
3727     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3728     return gcvt(val,ndig,loc);
3729   }
3730   else {
3731     loc[0] = '0'; loc[1] = '\0';
3732     return loc;
3733   }
3734
3735 }
3736 /*}}}*/
3737
3738
3739 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3740 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3741  * to expand file specification.  Allows for a single default file
3742  * specification and a simple mask of options.  If outbuf is non-NULL,
3743  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3744  * the resultant file specification is placed.  If outbuf is NULL, the
3745  * resultant file specification is placed into a static buffer.
3746  * The third argument, if non-NULL, is taken to be a default file
3747  * specification string.  The fourth argument is unused at present.
3748  * rmesexpand() returns the address of the resultant string if
3749  * successful, and NULL on error.
3750  */
3751 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3752
3753 static char *
3754 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3755 {
3756   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3757   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3758   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3759   struct FAB myfab = cc$rms_fab;
3760   struct NAM mynam = cc$rms_nam;
3761   STRLEN speclen;
3762   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3763   int sts;
3764
3765   if (!filespec || !*filespec) {
3766     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3767     return NULL;
3768   }
3769   if (!outbuf) {
3770     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3771     else    outbuf = __rmsexpand_retbuf;
3772   }
3773   isunix = is_unix_filespec(filespec);
3774   if (isunix) {
3775     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3776     filespec = vmsfspec;
3777   }
3778
3779   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3780   myfab.fab$b_fns = strlen(filespec);
3781   myfab.fab$l_nam = &mynam;
3782
3783   if (defspec && *defspec) {
3784     if (strchr(defspec,'/') != NULL) {
3785       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3786       defspec = tmpfspec;
3787     }
3788     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3789     myfab.fab$b_dns = strlen(defspec);
3790   }
3791
3792   mynam.nam$l_esa = esa;
3793   mynam.nam$b_ess = sizeof esa;
3794   mynam.nam$l_rsa = outbuf;
3795   mynam.nam$b_rss = NAM$C_MAXRSS;
3796
3797   retsts = sys$parse(&myfab,0,0);
3798   if (!(retsts & 1)) {
3799     mynam.nam$b_nop |= NAM$M_SYNCHK;
3800 #ifdef NAM$M_NO_SHORT_UPCASE
3801     if (decc_efs_case_preserve)
3802       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3803 #endif
3804     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3805       retsts = sys$parse(&myfab,0,0);
3806       if (retsts & 1) goto expanded;
3807     }
3808     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3809     sts = sys$parse(&myfab,0,0);  /* Free search context */
3810     if (out) Safefree(out);
3811     set_vaxc_errno(retsts);
3812     if      (retsts == RMS$_PRV) set_errno(EACCES);
3813     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3814     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3815     else                         set_errno(EVMSERR);
3816     return NULL;
3817   }
3818   retsts = sys$search(&myfab,0,0);
3819   if (!(retsts & 1) && retsts != RMS$_FNF) {
3820     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3821 #ifdef NAM$M_NO_SHORT_UPCASE
3822     if (decc_efs_case_preserve)
3823       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3824 #endif
3825     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3826     if (out) Safefree(out);
3827     set_vaxc_errno(retsts);
3828     if      (retsts == RMS$_PRV) set_errno(EACCES);
3829     else                         set_errno(EVMSERR);
3830     return NULL;
3831   }
3832
3833   /* If the input filespec contained any lowercase characters,
3834    * downcase the result for compatibility with Unix-minded code. */
3835   expanded:
3836   if (!decc_efs_case_preserve) {
3837     for (out = myfab.fab$l_fna; *out; out++)
3838       if (islower(*out)) { haslower = 1; break; }
3839   }
3840   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3841   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3842   /* Trim off null fields added by $PARSE
3843    * If type > 1 char, must have been specified in original or default spec
3844    * (not true for version; $SEARCH may have added version of existing file).
3845    */
3846   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3847   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3848              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3849   if (trimver || trimtype) {
3850     if (defspec && *defspec) {
3851       char defesa[NAM$C_MAXRSS];
3852       struct FAB deffab = cc$rms_fab;
3853       struct NAM defnam = cc$rms_nam;
3854
3855       deffab.fab$l_nam = &defnam;
3856       /* cast below ok for read only pointer */
3857       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3858       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3859       defnam.nam$b_nop = NAM$M_SYNCHK;
3860 #ifdef NAM$M_NO_SHORT_UPCASE
3861       if (decc_efs_case_preserve)
3862         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3863 #endif
3864       if (sys$parse(&deffab,0,0) & 1) {
3865         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3866         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3867       }
3868     }
3869     if (trimver) {
3870       if (*mynam.nam$l_ver != '\"')
3871         speclen = mynam.nam$l_ver - out;
3872     }
3873     if (trimtype) {
3874       /* If we didn't already trim version, copy down */
3875       if (speclen > mynam.nam$l_ver - out)
3876         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3877                speclen - (mynam.nam$l_ver - out));
3878       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3879     }
3880   }
3881   /* If we just had a directory spec on input, $PARSE "helpfully"
3882    * adds an empty name and type for us */
3883   if (mynam.nam$l_name == mynam.nam$l_type &&
3884       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
3885       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3886     speclen = mynam.nam$l_name - out;
3887
3888   /* Posix format specifications must have matching quotes */
3889   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
3890     if ((speclen > 1) && (out[speclen-1] != '\"')) {
3891       out[speclen] = '\"';
3892       speclen++;
3893     }
3894   }
3895
3896   out[speclen] = '\0';
3897   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3898
3899   /* Have we been working with an expanded, but not resultant, spec? */
3900   /* Also, convert back to Unix syntax if necessary. */
3901   if (!mynam.nam$b_rsl) {
3902     if (isunix) {
3903       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3904     }
3905     else strcpy(outbuf,esa);
3906   }
3907   else if (isunix) {
3908     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3909     strcpy(outbuf,tmpfspec);
3910   }
3911   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3912 #ifdef NAM$M_NO_SHORT_UPCASE
3913   if (decc_efs_case_preserve)
3914     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3915 #endif
3916   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3917   myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3918   return outbuf;
3919 }
3920 /*}}}*/
3921 /* External entry points */
3922 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3923 { return do_rmsexpand(spec,buf,0,def,opt); }
3924 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3925 { return do_rmsexpand(spec,buf,1,def,opt); }
3926
3927
3928 /*
3929 ** The following routines are provided to make life easier when
3930 ** converting among VMS-style and Unix-style directory specifications.
3931 ** All will take input specifications in either VMS or Unix syntax. On
3932 ** failure, all return NULL.  If successful, the routines listed below
3933 ** return a pointer to a buffer containing the appropriately
3934 ** reformatted spec (and, therefore, subsequent calls to that routine
3935 ** will clobber the result), while the routines of the same names with
3936 ** a _ts suffix appended will return a pointer to a mallocd string
3937 ** containing the appropriately reformatted spec.
3938 ** In all cases, only explicit syntax is altered; no check is made that
3939 ** the resulting string is valid or that the directory in question
3940 ** actually exists.
3941 **
3942 **   fileify_dirspec() - convert a directory spec into the name of the
3943 **     directory file (i.e. what you can stat() to see if it's a dir).
3944 **     The style (VMS or Unix) of the result is the same as the style
3945 **     of the parameter passed in.
3946 **   pathify_dirspec() - convert a directory spec into a path (i.e.
3947 **     what you prepend to a filename to indicate what directory it's in).
3948 **     The style (VMS or Unix) of the result is the same as the style
3949 **     of the parameter passed in.
3950 **   tounixpath() - convert a directory spec into a Unix-style path.
3951 **   tovmspath() - convert a directory spec into a VMS-style path.
3952 **   tounixspec() - convert any file spec into a Unix-style file spec.
3953 **   tovmsspec() - convert any file spec into a VMS-style spec.
3954 **
3955 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
3956 ** Permission is given to distribute this code as part of the Perl
3957 ** standard distribution under the terms of the GNU General Public
3958 ** License or the Perl Artistic License.  Copies of each may be
3959 ** found in the Perl standard distribution.
3960  */
3961
3962 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3963 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
3964 {
3965     static char __fileify_retbuf[NAM$C_MAXRSS+1];
3966     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3967     char *retspec, *cp1, *cp2, *lastdir;
3968     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3969     unsigned short int trnlnm_iter_count;
3970     int sts;
3971
3972     if (!dir || !*dir) {
3973       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3974     }
3975     dirlen = strlen(dir);
3976     while (dirlen && dir[dirlen-1] == '/') --dirlen;
3977     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3978       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
3979         dir = "/sys$disk";
3980         dirlen = 9;
3981       }
3982       else
3983         dirlen = 1;
3984     }
3985     if (dirlen > NAM$C_MAXRSS) {
3986       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3987     }
3988     if (!strpbrk(dir+1,"/]>:")  &&
3989         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
3990       strcpy(trndir,*dir == '/' ? dir + 1: dir);
3991       trnlnm_iter_count = 0;
3992       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3993         trnlnm_iter_count++;
3994         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3995       }
3996       dirlen = strlen(trndir);
3997     }
3998     else {
3999       strncpy(trndir,dir,dirlen);
4000       trndir[dirlen] = '\0';
4001     }
4002
4003     /* At this point we are done with *dir and use *trndir which is a
4004      * copy that can be modified.  *dir must not be modified.
4005      */
4006
4007     /* If we were handed a rooted logical name or spec, treat it like a
4008      * simple directory, so that
4009      *    $ Define myroot dev:[dir.]
4010      *    ... do_fileify_dirspec("myroot",buf,1) ...
4011      * does something useful.
4012      */
4013     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4014       trndir[--dirlen] = '\0';
4015       trndir[dirlen-1] = ']';
4016     }
4017     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4018       trndir[--dirlen] = '\0';
4019       trndir[dirlen-1] = '>';
4020     }
4021
4022     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4023       /* If we've got an explicit filename, we can just shuffle the string. */
4024       if (*(cp1+1)) hasfilename = 1;
4025       /* Similarly, we can just back up a level if we've got multiple levels
4026          of explicit directories in a VMS spec which ends with directories. */
4027       else {
4028         for (cp2 = cp1; cp2 > trndir; cp2--) {
4029           if (*cp2 == '.') {
4030             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4031               *cp2 = *cp1; *cp1 = '\0';
4032               hasfilename = 1;
4033               break;
4034             }
4035           }
4036           if (*cp2 == '[' || *cp2 == '<') break;
4037         }
4038       }
4039     }
4040
4041     cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
4042     if (hasfilename || !cp1) { /* Unix-style path or filename */
4043       if (trndir[0] == '.') {
4044         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
4045           return do_fileify_dirspec("[]",buf,ts);
4046         else if (trndir[1] == '.' &&
4047                  (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
4048           return do_fileify_dirspec("[-]",buf,ts);
4049       }
4050       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4051         dirlen -= 1;                 /* to last element */
4052         lastdir = strrchr(trndir,'/');
4053       }
4054       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4055         /* If we have "/." or "/..", VMSify it and let the VMS code
4056          * below expand it, rather than repeating the code to handle
4057          * relative components of a filespec here */
4058         do {
4059           if (*(cp1+2) == '.') cp1++;
4060           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4061             if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4062             if (strchr(vmsdir,'/') != NULL) {
4063               /* If do_tovmsspec() returned it, it must have VMS syntax
4064                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4065                * the time to check this here only so we avoid a recursion
4066                * loop; otherwise, gigo.
4067                */
4068               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
4069             }
4070             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4071             return do_tounixspec(trndir,buf,ts);
4072           }
4073           cp1++;
4074         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4075         lastdir = strrchr(trndir,'/');
4076       }
4077       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4078         /* Ditto for specs that end in an MFD -- let the VMS code
4079          * figure out whether it's a real device or a rooted logical. */
4080
4081         /* This should not happen any more.  Allowing the fake /000000
4082          * in a UNIX pathname causes all sorts of problems when trying
4083          * to run in UNIX emulation.  So the VMS to UNIX conversions
4084          * now remove the fake /000000 directories.
4085          */
4086
4087         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4088         if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4089         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4090         return do_tounixspec(trndir,buf,ts);
4091       }
4092       else {
4093
4094         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4095              !(lastdir = cp1 = strrchr(trndir,']')) &&
4096              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4097         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4098           int ver; char *cp3;
4099
4100           /* For EFS or ODS-5 look for the last dot */
4101           if (decc_efs_charset) {
4102               cp2 = strrchr(cp1,'.');
4103           }
4104           if (vms_process_case_tolerant) {
4105               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4106                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4107                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4108                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4109                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4110                             (ver || *cp3)))))) {
4111                   set_errno(ENOTDIR);
4112                   set_vaxc_errno(RMS$_DIR);
4113                   return NULL;
4114               }
4115           }
4116           else {
4117               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4118                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4119                   !*(cp2+3) || *(cp2+3) != 'R' ||
4120                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4121                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4122                             (ver || *cp3)))))) {
4123                  set_errno(ENOTDIR);
4124                  set_vaxc_errno(RMS$_DIR);
4125                  return NULL;
4126               }
4127           }
4128           dirlen = cp2 - trndir;
4129         }
4130       }
4131
4132       retlen = dirlen + 6;
4133       if (buf) retspec = buf;
4134       else if (ts) Newx(retspec,retlen+1,char);
4135       else retspec = __fileify_retbuf;
4136       memcpy(retspec,trndir,dirlen);
4137       retspec[dirlen] = '\0';
4138
4139       /* We've picked up everything up to the directory file name.
4140          Now just add the type and version, and we're set. */
4141       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4142         strcat(retspec,".dir;1");
4143       else
4144         strcat(retspec,".DIR;1");
4145       return retspec;
4146     }
4147     else {  /* VMS-style directory spec */
4148       char esa[NAM$C_MAXRSS+1], term, *cp;
4149       unsigned long int sts, cmplen, haslower = 0;
4150       struct FAB dirfab = cc$rms_fab;
4151       struct NAM savnam, dirnam = cc$rms_nam;
4152
4153       dirfab.fab$b_fns = strlen(trndir);
4154       dirfab.fab$l_fna = trndir;
4155       dirfab.fab$l_nam = &dirnam;
4156       dirfab.fab$l_dna = ".DIR;1";
4157       dirfab.fab$b_dns = 6;
4158       dirnam.nam$b_ess = NAM$C_MAXRSS;
4159       dirnam.nam$l_esa = esa;
4160 #ifdef NAM$M_NO_SHORT_UPCASE
4161       if (decc_efs_case_preserve)
4162         dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4163 #endif
4164
4165       for (cp = trndir; *cp; cp++)
4166         if (islower(*cp)) { haslower = 1; break; }
4167       if (!((sts = sys$parse(&dirfab))&1)) {
4168         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4169           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4170           sts = sys$parse(&dirfab) & 1;
4171         }
4172         if (!sts) {
4173           set_errno(EVMSERR);
4174           set_vaxc_errno(dirfab.fab$l_sts);
4175           return NULL;
4176         }
4177       }
4178       else {
4179         savnam = dirnam;
4180         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
4181           /* Yes; fake the fnb bits so we'll check type below */
4182           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
4183         }
4184         else { /* No; just work with potential name */
4185           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4186           else {
4187             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4188             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4189             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4190             return NULL;
4191           }
4192         }
4193       }
4194       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4195         cp1 = strchr(esa,']');
4196         if (!cp1) cp1 = strchr(esa,'>');
4197         if (cp1) {  /* Should always be true */
4198           dirnam.nam$b_esl -= cp1 - esa - 1;
4199           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
4200         }
4201       }
4202       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4203         /* Yep; check version while we're at it, if it's there. */
4204         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4205         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4206           /* Something other than .DIR[;1].  Bzzt. */
4207           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4208           dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4209           set_errno(ENOTDIR);
4210           set_vaxc_errno(RMS$_DIR);
4211           return NULL;
4212         }
4213       }
4214       esa[dirnam.nam$b_esl] = '\0';
4215       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
4216         /* They provided at least the name; we added the type, if necessary, */
4217         if (buf) retspec = buf;                            /* in sys$parse() */
4218         else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
4219         else retspec = __fileify_retbuf;
4220         strcpy(retspec,esa);
4221         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4222         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4223         return retspec;
4224       }
4225       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4226         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4227         *cp1 = '\0';
4228         dirnam.nam$b_esl -= 9;
4229       }
4230       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4231       if (cp1 == NULL) { /* should never happen */
4232         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4233         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4234         return NULL;
4235       }
4236       term = *cp1;
4237       *cp1 = '\0';
4238       retlen = strlen(esa);
4239       cp1 = strrchr(esa,'.');
4240       /* ODS-5 directory specifications can have extra "." in them. */
4241       while (cp1 != NULL) {
4242         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4243           break;
4244         else {
4245            cp1--;
4246            while ((cp1 > esa) && (*cp1 != '.'))
4247              cp1--;
4248         }
4249         if (cp1 == esa)
4250           cp1 = NULL;
4251       }
4252
4253       if ((cp1) != NULL) {
4254         /* There's more than one directory in the path.  Just roll back. */
4255         *cp1 = term;
4256         if (buf) retspec = buf;
4257         else if (ts) Newx(retspec,retlen+7,char);
4258         else retspec = __fileify_retbuf;
4259         strcpy(retspec,esa);
4260       }
4261       else {
4262         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
4263           /* Go back and expand rooted logical name */
4264           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
4265 #ifdef NAM$M_NO_SHORT_UPCASE
4266           if (decc_efs_case_preserve)
4267             dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4268 #endif
4269           if (!(sys$parse(&dirfab) & 1)) {
4270             dirnam.nam$l_rlf = NULL;
4271             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4272             set_errno(EVMSERR);
4273             set_vaxc_errno(dirfab.fab$l_sts);
4274             return NULL;
4275           }
4276           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
4277           if (buf) retspec = buf;
4278           else if (ts) Newx(retspec,retlen+16,char);
4279           else retspec = __fileify_retbuf;
4280           cp1 = strstr(esa,"][");
4281           if (!cp1) cp1 = strstr(esa,"]<");
4282           dirlen = cp1 - esa;
4283           memcpy(retspec,esa,dirlen);
4284           if (!strncmp(cp1+2,"000000]",7)) {
4285             retspec[dirlen-1] = '\0';
4286             /* Not full ODS-5, just extra dots in directories for now */
4287             cp1 = retspec + dirlen - 1;
4288             while (cp1 > retspec)
4289             {
4290               if (*cp1 == '[')
4291                 break;
4292               if (*cp1 == '.') {
4293                 if (*(cp1-1) != '^')
4294                   break;
4295               }
4296               cp1--;
4297             }
4298             if (*cp1 == '.') *cp1 = ']';
4299             else {
4300               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4301               memcpy(cp1+1,"000000]",7);
4302             }
4303           }
4304           else {
4305             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
4306             retspec[retlen] = '\0';
4307             /* Convert last '.' to ']' */
4308             cp1 = retspec+retlen-1;
4309             while (*cp != '[') {
4310               cp1--;
4311               if (*cp1 == '.') {
4312                 /* Do not trip on extra dots in ODS-5 directories */
4313                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4314                 break;
4315               }
4316             }
4317             if (*cp1 == '.') *cp1 = ']';
4318             else {
4319               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4320               memcpy(cp1+1,"000000]",7);
4321             }
4322           }
4323         }
4324         else {  /* This is a top-level dir.  Add the MFD to the path. */
4325           if (buf) retspec = buf;
4326           else if (ts) Newx(retspec,retlen+16,char);
4327           else retspec = __fileify_retbuf;
4328           cp1 = esa;
4329           cp2 = retspec;
4330           while (*cp1 != ':') *(cp2++) = *(cp1++);
4331           strcpy(cp2,":[000000]");
4332           cp1 += 2;
4333           strcpy(cp2+9,cp1);
4334         }
4335       }
4336       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4337       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4338       /* We've set up the string up through the filename.  Add the
4339          type and version, and we're done. */
4340       strcat(retspec,".DIR;1");
4341
4342       /* $PARSE may have upcased filespec, so convert output to lower
4343        * case if input contained any lowercase characters. */
4344       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4345       return retspec;
4346     }
4347 }  /* end of do_fileify_dirspec() */
4348 /*}}}*/
4349 /* External entry points */
4350 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4351 { return do_fileify_dirspec(dir,buf,0); }
4352 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4353 { return do_fileify_dirspec(dir,buf,1); }
4354
4355 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4356 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4357 {
4358     static char __pathify_retbuf[NAM$C_MAXRSS+1];
4359     unsigned long int retlen;
4360     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
4361     unsigned short int trnlnm_iter_count;
4362     STRLEN trnlen;
4363     int sts;
4364
4365     if (!dir || !*dir) {
4366       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4367     }
4368
4369     if (*dir) strcpy(trndir,dir);
4370     else getcwd(trndir,sizeof trndir - 1);
4371
4372     trnlnm_iter_count = 0;
4373     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4374            && my_trnlnm(trndir,trndir,0)) {
4375       trnlnm_iter_count++;
4376       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4377       trnlen = strlen(trndir);
4378
4379       /* Trap simple rooted lnms, and return lnm:[000000] */
4380       if (!strcmp(trndir+trnlen-2,".]")) {
4381         if (buf) retpath = buf;
4382         else if (ts) Newx(retpath,strlen(dir)+10,char);
4383         else retpath = __pathify_retbuf;
4384         strcpy(retpath,dir);
4385         strcat(retpath,":[000000]");
4386         return retpath;
4387       }
4388     }
4389
4390     /* At this point we do not work with *dir, but the copy in
4391      * *trndir that is modifiable.
4392      */
4393
4394     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4395       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4396                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4397         retlen = 2 + (*(trndir+1) != '\0');
4398       else {
4399         if ( !(cp1 = strrchr(trndir,'/')) &&
4400              !(cp1 = strrchr(trndir,']')) &&
4401              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4402         if ((cp2 = strchr(cp1,'.')) != NULL &&
4403             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4404              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4405               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4406               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4407           int ver; char *cp3;
4408
4409           /* For EFS or ODS-5 look for the last dot */
4410           if (decc_efs_charset) {
4411             cp2 = strrchr(cp1,'.');
4412           }
4413           if (vms_process_case_tolerant) {
4414               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4415                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4416                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4417                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4418                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4419                             (ver || *cp3)))))) {
4420                 set_errno(ENOTDIR);
4421                 set_vaxc_errno(RMS$_DIR);
4422                 return NULL;
4423               }
4424           }
4425           else {
4426               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4427                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4428                   !*(cp2+3) || *(cp2+3) != 'R' ||
4429                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4430                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4431                             (ver || *cp3)))))) {
4432                 set_errno(ENOTDIR);
4433                 set_vaxc_errno(RMS$_DIR);
4434                 return NULL;
4435               }
4436           }
4437           retlen = cp2 - trndir + 1;
4438         }
4439         else {  /* No file type present.  Treat the filename as a directory. */
4440           retlen = strlen(trndir) + 1;
4441         }
4442       }
4443       if (buf) retpath = buf;
4444       else if (ts) Newx(retpath,retlen+1,char);
4445       else retpath = __pathify_retbuf;
4446       strncpy(retpath, trndir, retlen-1);
4447       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4448         retpath[retlen-1] = '/';      /* with '/', add it. */
4449         retpath[retlen] = '\0';
4450       }
4451       else retpath[retlen-1] = '\0';
4452     }
4453     else {  /* VMS-style directory spec */
4454       char esa[NAM$C_MAXRSS+1], *cp;
4455       unsigned long int sts, cmplen, haslower;
4456       struct FAB dirfab = cc$rms_fab;
4457       struct NAM savnam, dirnam = cc$rms_nam;
4458
4459       /* If we've got an explicit filename, we can just shuffle the string. */
4460       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4461              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4462         if ((cp2 = strchr(cp1,'.')) != NULL) {
4463           int ver; char *cp3;
4464           if (vms_process_case_tolerant) {
4465               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4466                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4467                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4468                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4469                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4470                             (ver || *cp3)))))) {
4471                set_errno(ENOTDIR);
4472                set_vaxc_errno(RMS$_DIR);
4473                return NULL;
4474              }
4475           }
4476           else {
4477               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4478                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4479                   !*(cp2+3) || *(cp2+3) != 'R' ||
4480                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4481                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4482                             (ver || *cp3)))))) {
4483                set_errno(ENOTDIR);
4484                set_vaxc_errno(RMS$_DIR);
4485                return NULL;
4486              }
4487           }
4488         }
4489         else {  /* No file type, so just draw name into directory part */
4490           for (cp2 = cp1; *cp2; cp2++) ;
4491         }
4492         *cp2 = *cp1;
4493         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
4494         *cp1 = '.';
4495         /* We've now got a VMS 'path'; fall through */
4496       }
4497       dirfab.fab$b_fns = strlen(trndir);
4498       dirfab.fab$l_fna = trndir;
4499       if (trndir[dirfab.fab$b_fns-1] == ']' ||
4500           trndir[dirfab.fab$b_fns-1] == '>' ||
4501           trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4502         if (buf) retpath = buf;
4503         else if (ts) Newx(retpath,strlen(trndir)+1,char);
4504         else retpath = __pathify_retbuf;
4505         strcpy(retpath,trndir);
4506         return retpath;
4507       }
4508       dirfab.fab$l_dna = ".DIR;1";
4509       dirfab.fab$b_dns = 6;
4510       dirfab.fab$l_nam = &dirnam;
4511       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4512       dirnam.nam$l_esa = esa;
4513 #ifdef NAM$M_NO_SHORT_UPCASE
4514       if (decc_efs_case_preserve)
4515           dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4516 #endif
4517
4518       for (cp = trndir; *cp; cp++)
4519         if (islower(*cp)) { haslower = 1; break; }
4520
4521       if (!(sts = (sys$parse(&dirfab)&1))) {
4522         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4523           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4524           sts = sys$parse(&dirfab) & 1;
4525         }
4526         if (!sts) {
4527           set_errno(EVMSERR);
4528           set_vaxc_errno(dirfab.fab$l_sts);
4529           return NULL;
4530         }
4531       }
4532       else {
4533         savnam = dirnam;
4534         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
4535           if (dirfab.fab$l_sts != RMS$_FNF) {
4536             int sts1;
4537             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4538             dirfab.fab$b_dns = 0;
4539             sts1 = sys$parse(&dirfab,0,0);
4540             set_errno(EVMSERR);
4541             set_vaxc_errno(dirfab.fab$l_sts);
4542             return NULL;
4543           }
4544           dirnam = savnam; /* No; just work with potential name */
4545         }
4546       }
4547       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4548         /* Yep; check version while we're at it, if it's there. */
4549         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4550         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4551           int sts2;
4552           /* Something other than .DIR[;1].  Bzzt. */
4553           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4554           dirfab.fab$b_dns = 0;
4555           sts2 = sys$parse(&dirfab,0,0);
4556           set_errno(ENOTDIR);
4557           set_vaxc_errno(RMS$_DIR);
4558           return NULL;
4559         }
4560       }
4561       /* OK, the type was fine.  Now pull any file name into the
4562          directory path. */
4563       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4564       else {
4565         cp1 = strrchr(esa,'>');
4566         *dirnam.nam$l_type = '>';
4567       }
4568       *cp1 = '.';
4569       *(dirnam.nam$l_type + 1) = '\0';
4570       retlen = dirnam.nam$l_type - esa + 2;
4571       if (buf) retpath = buf;
4572       else if (ts) Newx(retpath,retlen,char);
4573       else retpath = __pathify_retbuf;
4574       strcpy(retpath,esa);
4575       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4576       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4577       /* $PARSE may have upcased filespec, so convert output to lower
4578        * case if input contained any lowercase characters. */
4579       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4580     }
4581
4582     return retpath;
4583 }  /* end of do_pathify_dirspec() */
4584 /*}}}*/
4585 /* External entry points */
4586 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4587 { return do_pathify_dirspec(dir,buf,0); }
4588 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4589 { return do_pathify_dirspec(dir,buf,1); }
4590
4591 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
4592 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4593 {
4594   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4595   char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4596   const char *cp2;
4597   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4598   int expand = 1; /* guarantee room for leading and trailing slashes */
4599   unsigned short int trnlnm_iter_count;
4600   int cmp_rslt;
4601
4602   if (spec == NULL) return NULL;
4603   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4604   if (buf) rslt = buf;
4605   else if (ts) {
4606     retlen = strlen(spec);
4607     cp1 = strchr(spec,'[');
4608     if (!cp1) cp1 = strchr(spec,'<');
4609     if (cp1) {
4610       for (cp1++; *cp1; cp1++) {
4611         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
4612         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4613           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4614       }
4615     }
4616     Newx(rslt,retlen+2+2*expand,char);
4617   }
4618   else rslt = __tounixspec_retbuf;
4619
4620   /* New VMS specific format needs translation
4621    * glob passes filenames with trailing '\n' and expects this preserved.
4622    */
4623   if (decc_posix_compliant_pathnames) {
4624     if (strncmp(spec, "\"^UP^", 5) == 0) {
4625       char * uspec;
4626       char *tunix;
4627       int tunix_len;
4628       int nl_flag;
4629
4630       Newx(tunix, VMS_MAXRSS + 1,char);
4631       strcpy(tunix, spec);
4632       tunix_len = strlen(tunix);
4633       nl_flag = 0;
4634       if (tunix[tunix_len - 1] == '\n') {
4635         tunix[tunix_len - 1] = '\"';
4636         tunix[tunix_len] = '\0';
4637         tunix_len--;
4638         nl_flag = 1;
4639       }
4640       uspec = decc$translate_vms(tunix);
4641       Safefree(tunix);
4642       if ((int)uspec > 0) {
4643         strcpy(rslt,uspec);
4644         if (nl_flag) {
4645           strcat(rslt,"\n");
4646         }
4647         else {
4648           /* If we can not translate it, makemaker wants as-is */
4649           strcpy(rslt, spec);
4650         }
4651         return rslt;
4652       }
4653     }
4654   }
4655
4656   cmp_rslt = 0; /* Presume VMS */
4657   cp1 = strchr(spec, '/');
4658   if (cp1 == NULL)
4659     cmp_rslt = 0;
4660
4661     /* Look for EFS ^/ */
4662     if (decc_efs_charset) {
4663       while (cp1 != NULL) {
4664         cp2 = cp1 - 1;
4665         if (*cp2 != '^') {
4666           /* Found illegal VMS, assume UNIX */
4667           cmp_rslt = 1;
4668           break;
4669         }
4670       cp1++;
4671       cp1 = strchr(cp1, '/');
4672     }
4673   }
4674
4675   /* Look for "." and ".." */
4676   if (decc_filename_unix_report) {
4677     if (spec[0] == '.') {
4678       if ((spec[1] == '\0') || (spec[1] == '\n')) {
4679         cmp_rslt = 1;
4680       }
4681       else {
4682         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
4683           cmp_rslt = 1;
4684         }
4685       }
4686     }
4687   }
4688   /* This is already UNIX or at least nothing VMS understands */
4689   if (cmp_rslt) {
4690     strcpy(rslt,spec);
4691     return rslt;
4692   }
4693
4694   cp1 = rslt;
4695   cp2 = spec;
4696   dirend = strrchr(spec,']');
4697   if (dirend == NULL) dirend = strrchr(spec,'>');
4698   if (dirend == NULL) dirend = strchr(spec,':');
4699   if (dirend == NULL) {
4700     strcpy(rslt,spec);
4701     return rslt;
4702   }
4703
4704   /* Special case 1 - sys$posix_root = / */
4705 #if __CRTL_VER >= 70000000
4706   if (!decc_disable_posix_root) {
4707     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
4708       *cp1 = '/';
4709       cp1++;
4710       cp2 = cp2 + 15;
4711       }
4712   }
4713 #endif
4714
4715   /* Special case 2 - Convert NLA0: to /dev/null */
4716 #if __CRTL_VER < 70000000
4717   cmp_rslt = strncmp(spec,"NLA0:", 5);
4718   if (cmp_rslt != 0)
4719      cmp_rslt = strncmp(spec,"nla0:", 5);
4720 #else
4721   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
4722 #endif
4723   if (cmp_rslt == 0) {
4724     strcpy(rslt, "/dev/null");
4725     cp1 = cp1 + 9;
4726     cp2 = cp2 + 5;
4727     if (spec[6] != '\0') {
4728       cp1[9] == '/';
4729       cp1++;
4730       cp2++;
4731     }
4732   }
4733
4734    /* Also handle special case "SYS$SCRATCH:" */
4735 #if __CRTL_VER < 70000000
4736   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
4737   if (cmp_rslt != 0)
4738      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
4739 #else
4740   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
4741 #endif
4742   if (cmp_rslt == 0) {
4743   int islnm;
4744
4745     islnm = my_trnlnm(tmp, "TMP", 0);
4746     if (!islnm) {
4747       strcpy(rslt, "/tmp");
4748       cp1 = cp1 + 4;
4749       cp2 = cp2 + 12;
4750       if (spec[12] != '\0') {
4751         cp1[4] == '/';
4752         cp1++;
4753         cp2++;
4754       }
4755     }
4756   }
4757
4758   if (*cp2 != '[' && *cp2 != '<') {
4759     *(cp1++) = '/';
4760   }
4761   else {  /* the VMS spec begins with directories */
4762     cp2++;
4763     if (*cp2 == ']' || *cp2 == '>') {
4764       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
4765       return rslt;
4766     }
4767     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
4768       if (getcwd(tmp,sizeof tmp,1) == NULL) {
4769         if (ts) Safefree(rslt);
4770         return NULL;
4771       }
4772       trnlnm_iter_count = 0;
4773       do {
4774         cp3 = tmp;
4775         while (*cp3 != ':' && *cp3) cp3++;
4776         *(cp3++) = '\0';
4777         if (strchr(cp3,']') != NULL) break;
4778         trnlnm_iter_count++;
4779         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
4780       } while (vmstrnenv(tmp,tmp,0,fildev,0));
4781       if (ts && !buf &&
4782           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
4783         retlen = devlen + dirlen;
4784         Renew(rslt,retlen+1+2*expand,char);
4785         cp1 = rslt;
4786       }
4787       cp3 = tmp;
4788       *(cp1++) = '/';
4789       while (*cp3) {
4790         *(cp1++) = *(cp3++);
4791         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
4792       }
4793       *(cp1++) = '/';
4794     }
4795     if ((*cp2 == '^')) {
4796         /* EFS file escape, pass the next character as is */
4797         /* Fix me: HEX encoding for UNICODE not implemented */
4798         cp2++;
4799     }
4800     else if ( *cp2 == '.') {
4801       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
4802         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4803         cp2 += 3;
4804       }
4805       else cp2++;
4806     }
4807   }
4808   for (; cp2 <= dirend; cp2++) {
4809     if ((*cp2 == '^')) {
4810         /* EFS file escape, pass the next character as is */
4811         /* Fix me: HEX encoding for UNICODE not implemented */
4812         cp2++;
4813         *(cp1++) = *cp2;
4814     }
4815     if (*cp2 == ':') {
4816       *(cp1++) = '/';
4817       if (*(cp2+1) == '[') cp2++;
4818     }
4819     else if (*cp2 == ']' || *cp2 == '>') {
4820       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
4821     }
4822     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
4823       *(cp1++) = '/';
4824       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
4825         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
4826                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
4827         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
4828             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
4829       }
4830       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
4831         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
4832         cp2 += 2;
4833       }
4834     }
4835     else if (*cp2 == '-') {
4836       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
4837         while (*cp2 == '-') {
4838           cp2++;
4839           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4840         }
4841         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
4842           if (ts) Safefree(rslt);                        /* filespecs like */
4843           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
4844           return NULL;
4845         }
4846       }
4847       else *(cp1++) = *cp2;
4848     }
4849     else *(cp1++) = *cp2;
4850   }
4851   while (*cp2) *(cp1++) = *(cp2++);
4852   *cp1 = '\0';
4853
4854   /* This still leaves /000000/ when working with a
4855    * VMS device root or concealed root.
4856    */
4857   {
4858   int ulen;
4859   char * zeros;
4860
4861       ulen = strlen(rslt);
4862
4863       /* Get rid of "000000/ in rooted filespecs */
4864       if (ulen > 7) {
4865         zeros = strstr(rslt, "/000000/");
4866         if (zeros != NULL) {
4867           int mlen;
4868           mlen = ulen - (zeros - rslt) - 7;
4869           memmove(zeros, &zeros[7], mlen);
4870           ulen = ulen - 7;
4871           rslt[ulen] = '\0';
4872         }
4873       }
4874   }
4875
4876   return rslt;
4877
4878 }  /* end of do_tounixspec() */
4879 /*}}}*/
4880 /* External entry points */
4881 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
4882 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
4883
4884 #if __CRTL_VER >= 80200000 && !defined(__VAX)
4885
4886 static int posix_to_vmsspec
4887   (char *vmspath, int vmspath_len, const char *unixpath) {
4888 int sts;
4889 struct FAB myfab = cc$rms_fab;
4890 struct NAML mynam = cc$rms_naml;
4891 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4892  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4893 char *esa;
4894 char *vms_delim;
4895 int dir_flag;
4896 int unixlen;
4897
4898   /* If not a posix spec already, convert it */
4899   dir_flag = 0;
4900   unixlen = strlen(unixpath);
4901   if (unixlen == 0) {
4902     vmspath[0] = '\0';
4903     return SS$_NORMAL;
4904   }
4905   if (strncmp(unixpath,"\"^UP^",5) != 0) {
4906     sprintf(vmspath,"\"^UP^%s\"",unixpath);
4907   }
4908   else {
4909     /* This is already a VMS specification, no conversion */
4910     unixlen--;
4911     strncpy(vmspath,unixpath, vmspath_len);
4912   }
4913   vmspath[vmspath_len] = 0;
4914   if (unixpath[unixlen - 1] == '/')
4915   dir_flag = 1;
4916   Newx(esa, VMS_MAXRSS+1, char);
4917   myfab.fab$l_fna = vmspath;
4918   myfab.fab$b_fns = strlen(vmspath);
4919   myfab.fab$l_naml = &mynam;
4920   mynam.naml$l_esa = NULL;
4921   mynam.naml$b_ess = 0;
4922   mynam.naml$l_long_expand = esa;
4923   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS;
4924   mynam.naml$l_rsa = NULL;
4925   mynam.naml$b_rss = 0;
4926   if (decc_efs_case_preserve)
4927     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4928   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
4929
4930   /* Set up the remaining naml fields */
4931   sts = sys$parse(&myfab);
4932
4933   /* It failed! Try again as a UNIX filespec */
4934   if (!(sts & 1)) {
4935     Safefree(esa);
4936     return sts;
4937   }
4938
4939    /* get the Device ID and the FID */
4940    sts = sys$search(&myfab);
4941    /* on any failure, returned the POSIX ^UP^ filespec */
4942    if (!(sts & 1)) {
4943       Safefree(esa);
4944       return sts;
4945    }
4946    specdsc.dsc$a_pointer = vmspath;
4947    specdsc.dsc$w_length = vmspath_len;
4948
4949    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
4950    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
4951    sts = lib$fid_to_name
4952       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
4953
4954   /* on any failure, returned the POSIX ^UP^ filespec */
4955   if (!(sts & 1)) {
4956      /* This can happen if user does not have permission to read directories */
4957      if (strncmp(unixpath,"\"^UP^",5) != 0)
4958        sprintf(vmspath,"\"^UP^%s\"",unixpath);
4959      else
4960        strcpy(vmspath, unixpath);
4961   }
4962   else {
4963     vmspath[specdsc.dsc$w_length] = 0;
4964
4965     /* Are we expecting a directory? */
4966     if (dir_flag != 0) {
4967     int i;
4968     char *eptr;
4969
4970       eptr = NULL;
4971
4972       i = specdsc.dsc$w_length - 1;
4973       while (i > 0) {
4974       int zercnt;
4975         zercnt = 0;
4976         /* Version must be '1' */
4977         if (vmspath[i--] != '1')
4978           break;
4979         /* Version delimiter is one of ".;" */
4980         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
4981           break;
4982         i--;
4983         if (vmspath[i--] != 'R')
4984           break;
4985         if (vmspath[i--] != 'I')
4986           break;
4987         if (vmspath[i--] != 'D')
4988           break;
4989         if (vmspath[i--] != '.')
4990           break;
4991         eptr = &vmspath[i+1];
4992         while (i > 0) {
4993           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
4994             if (vmspath[i-1] != '^') {
4995               if (zercnt != 6) {
4996                 *eptr = vmspath[i];
4997                 eptr[1] = '\0';
4998                 vmspath[i] = '.';
4999                 break;
5000               }
5001               else {
5002                 /* Get rid of 6 imaginary zero directory filename */
5003                 vmspath[i+1] = '\0';
5004               }
5005             }
5006           }
5007           if (vmspath[i] == '0')
5008             zercnt++;
5009           else
5010             zercnt = 10;
5011           i--;
5012         }
5013         break;
5014       }
5015     }
5016   }
5017   Safefree(esa);
5018   return sts;
5019 }
5020
5021 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5022 static int posix_to_vmsspec_hardway
5023   (char *vmspath, int vmspath_len, const char *unixpath) {
5024
5025 char *esa;
5026 const char *unixptr;
5027 char *vmsptr;
5028 const char *lastslash;
5029 const char *lastdot;
5030 int unixlen;
5031 int vmslen;
5032 int dir_start;
5033 int dir_dot;
5034 int quoted;
5035
5036
5037   unixptr = unixpath;
5038   dir_dot = 0;
5039
5040   /* Ignore leading "/" characters */
5041   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5042     unixptr++;
5043   }
5044   unixlen = strlen(unixptr);
5045
5046   /* Do nothing with blank paths */
5047   if (unixlen == 0) {
5048     vmspath[0] = '\0';
5049     return SS$_NORMAL;
5050   }
5051
5052   lastslash = strrchr(unixptr,'/');
5053   lastdot = strrchr(unixptr,'.');
5054
5055
5056   /* last dot is last dot or past end of string */
5057   if (lastdot == NULL)
5058     lastdot = unixptr + unixlen;
5059
5060   /* if no directories, set last slash to beginning of string */
5061   if (lastslash == NULL) {
5062     lastslash = unixptr;
5063   }
5064   else {
5065     /* Watch out for trailing "." after last slash, still a directory */
5066     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5067       lastslash = unixptr + unixlen;
5068     }
5069
5070     /* Watch out for traiing ".." after last slash, still a directory */
5071     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5072       lastslash = unixptr + unixlen;
5073     }
5074
5075     /* dots in directories are aways escaped */
5076     if (lastdot < lastslash)
5077       lastdot = unixptr + unixlen;
5078   }
5079
5080   /* if (unixptr < lastslash) then we are in a directory */
5081
5082   dir_start = 0;
5083   quoted = 0;
5084
5085   vmsptr = vmspath;
5086   vmslen = 0;
5087
5088   /* This could have a "^UP^ on the front */
5089   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5090     quoted = 1;
5091     unixptr+= 5;
5092   }
5093
5094   /* Start with the UNIX path */
5095   if (*unixptr != '/') {
5096     /* relative paths */
5097     if (lastslash > unixptr) {
5098     int dotdir_seen;
5099
5100       /* skip leading ./ */
5101       dotdir_seen = 0;
5102       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5103         dotdir_seen = 1;
5104         unixptr++;
5105         unixptr++;
5106       }
5107
5108       /* Are we still in a directory? */
5109       if (unixptr <= lastslash) {
5110         *vmsptr++ = '[';
5111         vmslen = 1;
5112         dir_start = 1;
5113
5114         /* if not backing up, then it is relative forward. */
5115         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5116               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5117           *vmsptr++ = '.';
5118           vmslen++;
5119           dir_dot = 1;
5120         }
5121        }
5122        else {
5123          if (dotdir_seen) {
5124            /* Perl wants an empty directory here to tell the difference
5125             * between a DCL commmand and a filename
5126             */
5127           *vmsptr++ = '[';
5128           *vmsptr++ = ']';
5129           vmslen = 2;
5130         }
5131       }
5132     }
5133     else {
5134       /* Handle two special files . and .. */
5135       if (unixptr[0] == '.') {
5136         if (unixptr[1] == '\0') {
5137           *vmsptr++ = '[';
5138           *vmsptr++ = ']';
5139           vmslen += 2;
5140           *vmsptr++ = '\0';
5141           return SS$_NORMAL;
5142         }
5143         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5144           *vmsptr++ = '[';
5145           *vmsptr++ = '-';
5146           *vmsptr++ = ']';
5147           vmslen += 3;
5148           *vmsptr++ = '\0';
5149           return SS$_NORMAL;
5150         }
5151       }
5152     }
5153   }
5154   else {        /* Absolute PATH handling */
5155   int sts;
5156   char * nextslash;
5157   int seg_len;
5158     /* Need to find out where root is */
5159
5160     /* In theory, this procedure should never get an absolute POSIX pathname
5161      * that can not be found on the POSIX root.
5162      * In practice, that can not be relied on, and things will show up
5163      * here that are a VMS device name or concealed logical name instead.
5164      * So to make things work, this procedure must be tolerant.
5165      */
5166     Newx(esa, vmspath_len, char);
5167
5168     sts = SS$_NORMAL;
5169     nextslash = strchr(&unixptr[1],'/');
5170     seg_len = 0;
5171     if (nextslash != NULL) {
5172       seg_len = nextslash - &unixptr[1];
5173       strncpy(vmspath, unixptr, seg_len + 1);
5174       vmspath[seg_len+1] = 0;
5175       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5176     }
5177
5178     if (sts & 1) {
5179       /* This is verified to be a real path */
5180
5181       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5182       strcpy(vmspath, esa);
5183       vmslen = strlen(vmspath);
5184       vmsptr = vmspath + vmslen;
5185       unixptr++;
5186       if (unixptr < lastslash) {
5187       char * rptr;
5188         vmsptr--;
5189         *vmsptr++ = '.';
5190         dir_start = 1;
5191         dir_dot = 1;
5192         if (vmslen > 7) {
5193         int cmp;
5194           rptr = vmsptr - 7;
5195           cmp = strcmp(rptr,"000000.");
5196           if (cmp == 0) {
5197             vmslen -= 7;
5198             vmsptr -= 7;
5199             vmsptr[1] = '\0';
5200           } /* removing 6 zeros */
5201         } /* vmslen < 7, no 6 zeros possible */
5202       } /* Not in a directory */
5203     } /* end of verified real path handling */
5204     else {
5205     int add_6zero;
5206     int islnm;
5207
5208       /* Ok, we have a device or a concealed root that is not in POSIX
5209        * or we have garbage.  Make the best of it.
5210        */
5211
5212       /* Posix to VMS destroyed this, so copy it again */
5213       strncpy(vmspath, &unixptr[1], seg_len);
5214       vmspath[seg_len] = 0;
5215       vmslen = seg_len;
5216       vmsptr = &vmsptr[vmslen];
5217       islnm = 0;
5218
5219       /* Now do we need to add the fake 6 zero directory to it? */
5220       add_6zero = 1;
5221       if ((*lastslash == '/') && (nextslash < lastslash)) {
5222         /* No there is another directory */
5223         add_6zero = 0;
5224       }
5225       else {
5226       int trnend;
5227
5228         /* now we have foo:bar or foo:[000000]bar to decide from */
5229         islnm = my_trnlnm(vmspath, esa, 0);
5230         trnend = islnm ? strlen(esa) - 1 : 0;
5231
5232         /* if this was a logical name, ']' or '>' must be present */
5233         /* if not a logical name, then assume a device and hope. */
5234         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5235
5236         /* if log name and trailing '.' then rooted - treat as device */
5237         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5238
5239         /* Fix me, if not a logical name, a device lookup should be
5240          * done to see if the device is file structured.  If the device
5241          * is not file structured, the 6 zeros should not be put on.
5242          *
5243          * As it is, perl is occasionally looking for dev:[000000]tty.
5244          * which looks a little strange.
5245          */
5246
5247         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5248           /* No real directory present */
5249           add_6zero = 1;
5250         }
5251       }
5252
5253       /* Put the device delimiter on */
5254       *vmsptr++ = ':';
5255       vmslen++;
5256       unixptr = nextslash;
5257       unixptr++;
5258
5259       /* Start directory if needed */
5260       if (!islnm || add_6zero) {
5261         *vmsptr++ = '[';
5262         vmslen++;
5263         dir_start = 1;
5264       }
5265
5266       /* add fake 000000] if needed */
5267       if (add_6zero) {
5268         *vmsptr++ = '0';
5269         *vmsptr++ = '0';
5270         *vmsptr++ = '0';
5271         *vmsptr++ = '0';
5272         *vmsptr++ = '0';
5273         *vmsptr++ = '0';
5274         *vmsptr++ = ']';
5275         vmslen += 7;
5276         dir_start = 0;
5277       }
5278
5279     } /* non-POSIX translation */
5280     Safefree(esa);
5281   } /* End of relative/absolute path handling */
5282
5283   while ((*unixptr) && (vmslen < vmspath_len)){
5284   int dash_flag;
5285
5286     dash_flag = 0;
5287
5288     if (dir_start != 0) {
5289
5290       /* First characters in a directory are handled special */
5291       while ((*unixptr == '/') ||
5292              ((*unixptr == '.') &&
5293               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5294       int loop_flag;
5295
5296         loop_flag = 0;
5297
5298         /* Skip redundant / in specification */
5299         while ((*unixptr == '/') && (dir_start != 0)) {
5300           loop_flag = 1;
5301           unixptr++;
5302           if (unixptr == lastslash)
5303             break;
5304         }
5305         if (unixptr == lastslash)
5306           break;
5307
5308         /* Skip redundant ./ characters */
5309         while ((*unixptr == '.') &&
5310                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5311           loop_flag = 1;
5312           unixptr++;
5313           if (unixptr == lastslash)
5314             break;
5315           if (*unixptr == '/')
5316             unixptr++;
5317         }
5318         if (unixptr == lastslash)
5319           break;
5320
5321         /* Skip redundant ../ characters */
5322         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5323              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5324           /* Set the backing up flag */
5325           loop_flag = 1;
5326           dir_dot = 0;
5327           dash_flag = 1;
5328           *vmsptr++ = '-';
5329           vmslen++;
5330           unixptr++; /* first . */
5331           unixptr++; /* second . */
5332           if (unixptr == lastslash)
5333             break;
5334           if (*unixptr == '/') /* The slash */
5335             unixptr++;
5336         }
5337         if (unixptr == lastslash)
5338           break;
5339
5340         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5341         /* Not needed when VMS is pretending to be UNIX. */
5342
5343         /* Is this loop stuck because of too many dots? */
5344         if (loop_flag == 0) {
5345           /* Exit the loop and pass the rest through */
5346           break;
5347         }
5348       }
5349
5350       /* Are we done with directories yet? */
5351       if (unixptr >= lastslash) {
5352
5353         /* Watch out for trailing dots */
5354         if (dir_dot != 0) {
5355             vmslen --;
5356             vmsptr--;
5357         }
5358         *vmsptr++ = ']';
5359         vmslen++;
5360         dash_flag = 0;
5361         dir_start = 0;
5362         if (*unixptr == '/')
5363           unixptr++;
5364       }
5365       else {
5366         /* Have we stopped backing up? */
5367         if (dash_flag) {
5368           *vmsptr++ = '.';
5369           vmslen++;
5370           dash_flag = 0;
5371           /* dir_start continues to be = 1 */
5372         }
5373         if (*unixptr == '-') {
5374           *vmsptr++ = '^';
5375           *vmsptr++ = *unixptr++;
5376           vmslen += 2;
5377           dir_start = 0;
5378
5379           /* Now are we done with directories yet? */
5380           if (unixptr >= lastslash) {
5381
5382             /* Watch out for trailing dots */
5383             if (dir_dot != 0) {
5384               vmslen --;
5385               vmsptr--;
5386             }
5387
5388             *vmsptr++ = ']';
5389             vmslen++;
5390             dash_flag = 0;
5391             dir_start = 0;
5392           }
5393         }
5394       }
5395     }
5396
5397     /* All done? */
5398     if (*unixptr == '\0')
5399       break;
5400
5401     /* Normal characters - More EFS work probably needed */
5402     dir_start = 0;
5403     dir_dot = 0;
5404
5405     switch(*unixptr) {
5406     case '/':
5407         /* remove multiple / */
5408         while (unixptr[1] == '/') {
5409            unixptr++;
5410         }
5411         if (unixptr == lastslash) {
5412           /* Watch out for trailing dots */
5413           if (dir_dot != 0) {
5414             vmslen --;
5415             vmsptr--;
5416           }
5417           *vmsptr++ = ']';
5418         }
5419         else {
5420           dir_start = 1;
5421           *vmsptr++ = '.';
5422           dir_dot = 1;
5423
5424           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5425           /* Not needed when VMS is pretending to be UNIX. */
5426
5427         }
5428         dash_flag = 0;
5429         if (*unixptr != '\0')
5430           unixptr++;
5431         vmslen++;
5432         break;
5433     case '?':
5434         *vmsptr++ = '%';
5435         vmslen++;
5436         unixptr++;
5437         break;
5438     case ' ':
5439         *vmsptr++ = '^';
5440         *vmsptr++ = '_';
5441         vmslen += 2;
5442         unixptr++;
5443         break;
5444     case '.':
5445         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5446           *vmsptr++ = '^';
5447           *vmsptr++ = '.';
5448           vmslen += 2;
5449           unixptr++;
5450
5451           /* trailing dot ==> '^..' on VMS */
5452           if (*unixptr == '\0') {
5453             *vmsptr++ = '.';
5454             vmslen++;
5455           }
5456           *vmsptr++ = *unixptr++;
5457           vmslen ++;
5458         }
5459         if (quoted && (unixptr[1] == '\0')) {
5460           unixptr++;
5461           break;
5462         }
5463         *vmsptr++ = '^';
5464         *vmsptr++ = *unixptr++;
5465         vmslen += 2;
5466         break;
5467     case '~':
5468     case ';':
5469     case '\\':
5470         *vmsptr++ = '^';
5471         *vmsptr++ = *unixptr++;
5472         vmslen += 2;
5473         break;
5474     default:
5475         if (*unixptr != '\0') {
5476           *vmsptr++ = *unixptr++;
5477           vmslen++;
5478         }
5479         break;
5480     }
5481   }
5482
5483   /* Make sure directory is closed */
5484   if (unixptr == lastslash) {
5485     char *vmsptr2;
5486     vmsptr2 = vmsptr - 1;
5487
5488     if (*vmsptr2 != ']') {
5489       *vmsptr2--;
5490
5491       /* directories do not end in a dot bracket */
5492       if (*vmsptr2 == '.') {
5493         vmsptr2--;
5494
5495         /* ^. is allowed */
5496         if (*vmsptr2 != '^') {
5497           vmsptr--; /* back up over the dot */
5498         }
5499       }
5500       *vmsptr++ = ']';
5501     }
5502   }
5503   else {
5504     char *vmsptr2;
5505     /* Add a trailing dot if a file with no extension */
5506     vmsptr2 = vmsptr - 1;
5507     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
5508         (*lastdot != '.')) {
5509         *vmsptr++ = '.';
5510         vmslen++;
5511     }
5512   }
5513
5514   *vmsptr = '\0';
5515   return SS$_NORMAL;
5516 }
5517 #endif
5518
5519 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
5520 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
5521   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
5522   char *rslt, *dirend;
5523   char *lastdot;
5524   char *vms_delim;
5525   register char *cp1;
5526   const char *cp2;
5527   unsigned long int infront = 0, hasdir = 1;
5528   int rslt_len;
5529   int no_type_seen;
5530
5531   if (path == NULL) return NULL;
5532   rslt_len = VMS_MAXRSS;
5533   if (buf) rslt = buf;
5534   else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char);
5535   else rslt = __tovmsspec_retbuf;
5536   if (strpbrk(path,"]:>") ||
5537       (dirend = strrchr(path,'/')) == NULL) {
5538     if (path[0] == '.') {
5539       if (path[1] == '\0') strcpy(rslt,"[]");
5540       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
5541       else strcpy(rslt,path); /* probably garbage */
5542     }
5543     else strcpy(rslt,path);
5544     return rslt;
5545   }
5546
5547    /* Posix specifications are now a native VMS format */
5548   /*--------------------------------------------------*/
5549 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5550   if (decc_posix_compliant_pathnames) {
5551     if (strncmp(path,"\"^UP^",5) == 0) {
5552       posix_to_vmsspec_hardway(rslt, rslt_len, path);
5553       return rslt;
5554     }
5555   }
5556 #endif
5557
5558   vms_delim = strpbrk(path,"]:>");
5559
5560   if ((vms_delim != NULL) ||
5561       ((dirend = strrchr(path,'/')) == NULL)) {
5562
5563     /* VMS special characters found! */
5564
5565     if (path[0] == '.') {
5566       if (path[1] == '\0') strcpy(rslt,"[]");
5567       else if (path[1] == '.' && path[2] == '\0')
5568         strcpy(rslt,"[-]");
5569
5570       /* Dot preceeding a device or directory ? */
5571       else {
5572         /* If not in POSIX mode, pass it through and hope it works */
5573 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5574         if (!decc_posix_compliant_pathnames)
5575           strcpy(rslt,path); /* probably garbage */
5576         else
5577           posix_to_vmsspec_hardway(rslt, rslt_len, path);
5578 #else
5579         strcpy(rslt,path); /* probably garbage */
5580 #endif
5581       }
5582     }
5583     else {
5584
5585        /* If no VMS characters and in POSIX mode, convert it!
5586         * This is the easiest way to get directory specifications
5587         * handled correctly in POSIX mode
5588         */
5589 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5590       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
5591         posix_to_vmsspec_hardway(rslt, rslt_len, path);
5592       else {
5593         /* No unix path separators - presume VMS already */
5594         strcpy(rslt,path);
5595       }
5596 #else
5597       strcpy(rslt,path); /* probably garbage */
5598 #endif
5599     }
5600     return rslt;
5601   }
5602
5603 /* If POSIX mode active, handle the conversion */
5604 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5605   if (decc_posix_compliant_pathnames) {
5606     posix_to_vmsspec_hardway(rslt, rslt_len, path);
5607     return rslt;
5608   }
5609 #endif
5610
5611   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
5612     if (!*(dirend+2)) dirend +=2;
5613     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
5614     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
5615   }
5616
5617   cp1 = rslt;
5618   cp2 = path;
5619   lastdot = strrchr(cp2,'.');
5620   if (*cp2 == '/') {
5621     char trndev[NAM$C_MAXRSS+1];
5622     int islnm, rooted;
5623     STRLEN trnend;
5624
5625     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
5626     if (!*(cp2+1)) {
5627       if (decc_disable_posix_root) {
5628         strcpy(rslt,"sys$disk:[000000]");
5629       }
5630       else {
5631         strcpy(rslt,"sys$posix_root:[000000]");
5632       }
5633       return rslt;
5634     }
5635     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
5636     *cp1 = '\0';
5637     islnm =  my_trnlnm(rslt,trndev,0);
5638
5639      /* DECC special handling */
5640     if (!islnm) {
5641       if (strcmp(rslt,"bin") == 0) {
5642         strcpy(rslt,"sys$system");
5643         cp1 = rslt + 10;
5644         *cp1 = 0;
5645         islnm =  my_trnlnm(rslt,trndev,0);
5646       }
5647       else if (strcmp(rslt,"tmp") == 0) {
5648         strcpy(rslt,"sys$scratch");
5649         cp1 = rslt + 11;
5650         *cp1 = 0;
5651         islnm =  my_trnlnm(rslt,trndev,0);
5652       }
5653       else if (!decc_disable_posix_root) {
5654         strcpy(rslt, "sys$posix_root");
5655         cp1 = rslt + 13;
5656         *cp1 = 0;
5657         cp2 = path;
5658         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
5659         islnm =  my_trnlnm(rslt,trndev,0);
5660       }
5661       else if (strcmp(rslt,"dev") == 0) {
5662         if (strncmp(cp2,"/null", 5) == 0) {
5663           if ((cp2[5] == 0) || (cp2[5] == '/')) {
5664             strcpy(rslt,"NLA0");
5665             cp1 = rslt + 4;
5666             *cp1 = 0;
5667             cp2 = cp2 + 5;
5668             islnm =  my_trnlnm(rslt,trndev,0);
5669           }
5670         }
5671       }
5672     }
5673
5674     trnend = islnm ? strlen(trndev) - 1 : 0;
5675     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
5676     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
5677     /* If the first element of the path is a logical name, determine
5678      * whether it has to be translated so we can add more directories. */
5679     if (!islnm || rooted) {
5680       *(cp1++) = ':';
5681       *(cp1++) = '[';
5682       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
5683       else cp2++;
5684     }
5685     else {
5686       if (cp2 != dirend) {
5687         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
5688         strcpy(rslt,trndev);
5689         cp1 = rslt + trnend;
5690         if (*cp2 != 0) {
5691           *(cp1++) = '.';
5692           cp2++;
5693         }
5694       }
5695       else {
5696         if (decc_disable_posix_root) {
5697           *(cp1++) = ':';
5698           hasdir = 0;
5699         }
5700       }
5701     }
5702   }
5703   else {
5704     *(cp1++) = '[';
5705     if (*cp2 == '.') {
5706       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
5707         cp2 += 2;         /* skip over "./" - it's redundant */
5708         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
5709       }
5710       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
5711         *(cp1++) = '-';                                 /* "../" --> "-" */
5712         cp2 += 3;
5713       }
5714       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
5715                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
5716         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
5717         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
5718         cp2 += 4;
5719       }
5720       else if ((cp2 != lastdot) || (lastdot < dirend)) {
5721         /* Escape the extra dots in EFS file specifications */
5722         *(cp1++) = '^';
5723       }
5724       if (cp2 > dirend) cp2 = dirend;
5725     }
5726     else *(cp1++) = '.';
5727   }
5728   for (; cp2 < dirend; cp2++) {
5729     if (*cp2 == '/') {
5730       if (*(cp2-1) == '/') continue;
5731       if (*(cp1-1) != '.') *(cp1++) = '.';
5732       infront = 0;
5733     }
5734     else if (!infront && *cp2 == '.') {
5735       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
5736       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
5737       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
5738         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
5739         else if (*(cp1-2) == '[') *(cp1-1) = '-';
5740         else {  /* back up over previous directory name */
5741           cp1--;
5742           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
5743           if (*(cp1-1) == '[') {
5744             memcpy(cp1,"000000.",7);
5745             cp1 += 7;
5746           }
5747         }
5748         cp2 += 2;
5749         if (cp2 == dirend) break;
5750       }
5751       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
5752                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
5753         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
5754         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
5755         if (!*(cp2+3)) {
5756           *(cp1++) = '.';  /* Simulate trailing '/' */
5757           cp2 += 2;  /* for loop will incr this to == dirend */
5758         }
5759         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
5760       }
5761       else {
5762         if (decc_efs_charset == 0)
5763           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
5764         else {
5765           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
5766           *(cp1++) = '.';
5767         }
5768       }
5769     }
5770     else {
5771       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
5772       if (*cp2 == '.') {
5773         if (decc_efs_charset == 0)
5774           *(cp1++) = '_';
5775         else {
5776           *(cp1++) = '^';
5777           *(cp1++) = '.';
5778         }
5779       }
5780       else                  *(cp1++) =  *cp2;
5781       infront = 1;
5782     }
5783   }
5784   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
5785   if (hasdir) *(cp1++) = ']';
5786   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
5787   /* fixme for ODS5 */
5788   no_type_seen = 0;
5789   if (cp2 > lastdot)
5790     no_type_seen = 1;
5791   while (*cp2) {
5792     switch(*cp2) {
5793     case '?':
5794         *(cp1++) = '%';
5795         cp2++;
5796     case ' ':
5797         *(cp1)++ = '^';
5798         *(cp1)++ = '_';
5799         cp2++;
5800         break;
5801     case '.':
5802         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
5803             decc_readdir_dropdotnotype) {
5804           *(cp1)++ = '^';
5805           *(cp1)++ = '.';
5806           cp2++;
5807
5808           /* trailing dot ==> '^..' on VMS */
5809           if (*cp2 == '\0') {
5810             *(cp1++) = '.';
5811             no_type_seen = 0;
5812           }
5813         }
5814         else {
5815           *(cp1++) = *(cp2++);
5816           no_type_seen = 0;
5817         }
5818         break;
5819     case '\"':
5820     case '~':
5821     case '`':
5822     case '!':
5823     case '#':
5824     case '%':
5825     case '^':
5826     case '&':
5827     case '(':
5828     case ')':
5829     case '=':
5830     case '+':
5831     case '\'':
5832     case '@':
5833     case '[':
5834     case ']':
5835     case '{':
5836     case '}':
5837     case ':':
5838     case '\\':
5839     case '|':
5840     case '<':
5841     case '>':
5842         *(cp1++) = '^';
5843         *(cp1++) = *(cp2++);
5844         break;
5845     case ';':
5846         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
5847          * which is wrong.  UNIX notation should be ".dir. unless
5848          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
5849          * changing this behavior could break more things at this time.
5850          * efs character set effectively does not allow "." to be a version
5851          * delimiter as a further complication about changing this.
5852          */
5853         if (decc_filename_unix_report != 0) {
5854           *(cp1++) = '^';
5855         }
5856         *(cp1++) = *(cp2++);
5857         break;
5858     default:
5859         *(cp1++) = *(cp2++);
5860     }
5861   }
5862   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
5863   char *lcp1;
5864     lcp1 = cp1;
5865     lcp1--;
5866      /* Fix me for "^]", but that requires making sure that you do
5867       * not back up past the start of the filename
5868       */
5869     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
5870       *cp1++ = '.';
5871   }
5872   *cp1 = '\0';
5873
5874   return rslt;
5875
5876 }  /* end of do_tovmsspec() */
5877 /*}}}*/
5878 /* External entry points */
5879 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
5880 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
5881
5882 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
5883 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
5884   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
5885   int vmslen;
5886   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
5887
5888   if (path == NULL) return NULL;
5889   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
5890   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
5891   if (buf) return buf;
5892   else if (ts) {
5893     vmslen = strlen(vmsified);
5894     Newx(cp,vmslen+1,char);
5895     memcpy(cp,vmsified,vmslen);
5896     cp[vmslen] = '\0';
5897     return cp;
5898   }
5899   else {
5900     strcpy(__tovmspath_retbuf,vmsified);
5901     return __tovmspath_retbuf;
5902   }
5903
5904 }  /* end of do_tovmspath() */
5905 /*}}}*/
5906 /* External entry points */
5907 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
5908 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
5909
5910
5911 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
5912 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
5913   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
5914   int unixlen;
5915   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
5916
5917   if (path == NULL) return NULL;
5918   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
5919   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
5920   if (buf) return buf;
5921   else if (ts) {
5922     unixlen = strlen(unixified);
5923     Newx(cp,unixlen+1,char);
5924     memcpy(cp,unixified,unixlen);
5925     cp[unixlen] = '\0';
5926     return cp;
5927   }
5928   else {
5929     strcpy(__tounixpath_retbuf,unixified);
5930     return __tounixpath_retbuf;
5931   }
5932
5933 }  /* end of do_tounixpath() */
5934 /*}}}*/
5935 /* External entry points */
5936 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
5937 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
5938
5939 /*
5940  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
5941  *
5942  *****************************************************************************
5943  *                                                                           *
5944  *  Copyright (C) 1989-1994 by                                               *
5945  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
5946  *                                                                           *
5947  *  Permission is hereby  granted for the reproduction of this software,     *
5948  *  on condition that this copyright notice is included in the reproduction, *
5949  *  and that such reproduction is not for purposes of profit or material     *
5950  *  gain.                                                                    *
5951  *                                                                           *
5952  *  27-Aug-1994 Modified for inclusion in perl5                              *
5953  *              by Charles Bailey  bailey@newman.upenn.edu                   *
5954  *****************************************************************************
5955  */
5956
5957 /*
5958  * getredirection() is intended to aid in porting C programs
5959  * to VMS (Vax-11 C).  The native VMS environment does not support
5960  * '>' and '<' I/O redirection, or command line wild card expansion,
5961  * or a command line pipe mechanism using the '|' AND background
5962  * command execution '&'.  All of these capabilities are provided to any
5963  * C program which calls this procedure as the first thing in the
5964  * main program.
5965  * The piping mechanism will probably work with almost any 'filter' type
5966  * of program.  With suitable modification, it may useful for other
5967  * portability problems as well.
5968  *
5969  * Author:  Mark Pizzolato      mark@infocomm.com
5970  */
5971 struct list_item
5972     {
5973     struct list_item *next;
5974     char *value;
5975     };
5976
5977 static void add_item(struct list_item **head,
5978                      struct list_item **tail,
5979                      char *value,
5980                      int *count);
5981
5982 static void mp_expand_wild_cards(pTHX_ char *item,
5983                                 struct list_item **head,
5984                                 struct list_item **tail,
5985                                 int *count);
5986
5987 static int background_process(pTHX_ int argc, char **argv);
5988
5989 static void pipe_and_fork(pTHX_ char **cmargv);
5990
5991 /*{{{ void getredirection(int *ac, char ***av)*/
5992 static void
5993 mp_getredirection(pTHX_ int *ac, char ***av)
5994 /*
5995  * Process vms redirection arg's.  Exit if any error is seen.
5996  * If getredirection() processes an argument, it is erased
5997  * from the vector.  getredirection() returns a new argc and argv value.
5998  * In the event that a background command is requested (by a trailing "&"),
5999  * this routine creates a background subprocess, and simply exits the program.
6000  *
6001  * Warning: do not try to simplify the code for vms.  The code
6002  * presupposes that getredirection() is called before any data is
6003  * read from stdin or written to stdout.
6004  *
6005  * Normal usage is as follows:
6006  *
6007  *      main(argc, argv)
6008  *      int             argc;
6009  *      char            *argv[];
6010  *      {
6011  *              getredirection(&argc, &argv);
6012  *      }
6013  */
6014 {
6015     int                 argc = *ac;     /* Argument Count         */
6016     char                **argv = *av;   /* Argument Vector        */
6017     char                *ap;            /* Argument pointer       */
6018     int                 j;              /* argv[] index           */
6019     int                 item_count = 0; /* Count of Items in List */
6020     struct list_item    *list_head = 0; /* First Item in List       */
6021     struct list_item    *list_tail;     /* Last Item in List        */
6022     char                *in = NULL;     /* Input File Name          */
6023     char                *out = NULL;    /* Output File Name         */
6024     char                *outmode = "w"; /* Mode to Open Output File */
6025     char                *err = NULL;    /* Error File Name          */
6026     char                *errmode = "w"; /* Mode to Open Error File  */
6027     int                 cmargc = 0;     /* Piped Command Arg Count  */
6028     char                **cmargv = NULL;/* Piped Command Arg Vector */
6029
6030     /*
6031      * First handle the case where the last thing on the line ends with
6032      * a '&'.  This indicates the desire for the command to be run in a
6033      * subprocess, so we satisfy that desire.
6034      */
6035     ap = argv[argc-1];
6036     if (0 == strcmp("&", ap))
6037        exit(background_process(aTHX_ --argc, argv));
6038     if (*ap && '&' == ap[strlen(ap)-1])
6039         {
6040         ap[strlen(ap)-1] = '\0';
6041        exit(background_process(aTHX_ argc, argv));
6042         }
6043     /*
6044      * Now we handle the general redirection cases that involve '>', '>>',
6045      * '<', and pipes '|'.
6046      */
6047     for (j = 0; j < argc; ++j)
6048         {
6049         if (0 == strcmp("<", argv[j]))
6050             {
6051             if (j+1 >= argc)
6052                 {
6053                 fprintf(stderr,"No input file after < on command line");
6054                 exit(LIB$_WRONUMARG);
6055                 }
6056             in = argv[++j];
6057             continue;
6058             }
6059         if ('<' == *(ap = argv[j]))
6060             {
6061             in = 1 + ap;
6062             continue;
6063             }
6064         if (0 == strcmp(">", ap))
6065             {
6066             if (j+1 >= argc)
6067                 {
6068                 fprintf(stderr,"No output file after > on command line");
6069                 exit(LIB$_WRONUMARG);
6070                 }
6071             out = argv[++j];
6072             continue;
6073             }
6074         if ('>' == *ap)
6075             {
6076             if ('>' == ap[1])
6077                 {
6078                 outmode = "a";
6079                 if ('\0' == ap[2])
6080                     out = argv[++j];
6081                 else
6082                     out = 2 + ap;
6083                 }
6084             else
6085                 out = 1 + ap;
6086             if (j >= argc)
6087                 {
6088                 fprintf(stderr,"No output file after > or >> on command line");
6089                 exit(LIB$_WRONUMARG);
6090                 }
6091             continue;
6092             }
6093         if (('2' == *ap) && ('>' == ap[1]))
6094             {
6095             if ('>' == ap[2])
6096                 {
6097                 errmode = "a";
6098                 if ('\0' == ap[3])
6099                     err = argv[++j];
6100                 else
6101                     err = 3 + ap;
6102                 }
6103             else
6104                 if ('\0' == ap[2])
6105                     err = argv[++j];
6106                 else
6107                     err = 2 + ap;
6108             if (j >= argc)
6109                 {
6110                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6111                 exit(LIB$_WRONUMARG);
6112                 }
6113             continue;
6114             }
6115         if (0 == strcmp("|", argv[j]))
6116             {
6117             if (j+1 >= argc)
6118                 {
6119                 fprintf(stderr,"No command into which to pipe on command line");
6120                 exit(LIB$_WRONUMARG);
6121                 }
6122             cmargc = argc-(j+1);
6123             cmargv = &argv[j+1];
6124             argc = j;
6125             continue;
6126             }
6127         if ('|' == *(ap = argv[j]))
6128             {
6129             ++argv[j];
6130             cmargc = argc-j;
6131             cmargv = &argv[j];
6132             argc = j;
6133             continue;
6134             }
6135         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6136         }
6137     /*
6138      * Allocate and fill in the new argument vector, Some Unix's terminate
6139      * the list with an extra null pointer.
6140      */
6141     Newx(argv, item_count+1, char *);
6142     *av = argv;
6143     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6144         argv[j] = list_head->value;
6145     *ac = item_count;
6146     if (cmargv != NULL)
6147         {
6148         if (out != NULL)
6149             {
6150             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6151             exit(LIB$_INVARGORD);
6152             }
6153         pipe_and_fork(aTHX_ cmargv);
6154         }
6155
6156     /* Check for input from a pipe (mailbox) */
6157
6158     if (in == NULL && 1 == isapipe(0))
6159         {
6160         char mbxname[L_tmpnam];
6161         long int bufsize;
6162         long int dvi_item = DVI$_DEVBUFSIZ;
6163         $DESCRIPTOR(mbxnam, "");
6164         $DESCRIPTOR(mbxdevnam, "");
6165
6166         /* Input from a pipe, reopen it in binary mode to disable       */
6167         /* carriage control processing.                                 */
6168
6169         fgetname(stdin, mbxname);
6170         mbxnam.dsc$a_pointer = mbxname;
6171         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6172         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6173         mbxdevnam.dsc$a_pointer = mbxname;
6174         mbxdevnam.dsc$w_length = sizeof(mbxname);
6175         dvi_item = DVI$_DEVNAM;
6176         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6177         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6178         set_errno(0);
6179         set_vaxc_errno(1);
6180         freopen(mbxname, "rb", stdin);
6181         if (errno != 0)
6182             {
6183             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6184             exit(vaxc$errno);
6185             }
6186         }
6187     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6188         {
6189         fprintf(stderr,"Can't open input file %s as stdin",in);
6190         exit(vaxc$errno);
6191         }
6192     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6193         {
6194         fprintf(stderr,"Can't open output file %s as stdout",out);
6195         exit(vaxc$errno);
6196         }
6197         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6198
6199     if (err != NULL) {
6200         if (strcmp(err,"&1") == 0) {
6201             dup2(fileno(stdout), fileno(stderr));
6202             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6203         } else {
6204         FILE *tmperr;
6205         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6206             {
6207             fprintf(stderr,"Can't open error file %s as stderr",err);
6208             exit(vaxc$errno);
6209             }
6210             fclose(tmperr);
6211            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6212                 {
6213                 exit(vaxc$errno);
6214                 }
6215             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6216         }
6217         }
6218 #ifdef ARGPROC_DEBUG
6219     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6220     for (j = 0; j < *ac;  ++j)
6221         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6222 #endif
6223    /* Clear errors we may have hit expanding wildcards, so they don't
6224       show up in Perl's $! later */
6225    set_errno(0); set_vaxc_errno(1);
6226 }  /* end of getredirection() */
6227 /*}}}*/
6228
6229 static void add_item(struct list_item **head,
6230                      struct list_item **tail,
6231                      char *value,
6232                      int *count)
6233 {
6234     if (*head == 0)
6235         {
6236         Newx(*head,1,struct list_item);
6237         *tail = *head;
6238         }
6239     else {
6240         Newx((*tail)->next,1,struct list_item);
6241         *tail = (*tail)->next;
6242         }
6243     (*tail)->value = value;
6244     ++(*count);
6245 }
6246
6247 static void mp_expand_wild_cards(pTHX_ char *item,
6248                               struct list_item **head,
6249                               struct list_item **tail,
6250                               int *count)
6251 {
6252 int expcount = 0;
6253 unsigned long int context = 0;
6254 int isunix = 0;
6255 int item_len = 0;
6256 char *had_version;
6257 char *had_device;
6258 int had_directory;
6259 char *devdir,*cp;
6260 char vmsspec[NAM$C_MAXRSS+1];
6261 $DESCRIPTOR(filespec, "");
6262 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6263 $DESCRIPTOR(resultspec, "");
6264 unsigned long int zero = 0, sts;
6265
6266     for (cp = item; *cp; cp++) {
6267         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6268         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6269     }
6270     if (!*cp || isspace(*cp))
6271         {
6272         add_item(head, tail, item, count);
6273         return;
6274         }
6275     else
6276         {
6277      /* "double quoted" wild card expressions pass as is */
6278      /* From DCL that means using e.g.:                  */
6279      /* perl program """perl.*"""                        */
6280      item_len = strlen(item);
6281      if ( '"' == *item && '"' == item[item_len-1] )
6282        {
6283        item++;
6284        item[item_len-2] = '\0';
6285        add_item(head, tail, item, count);
6286        return;
6287        }
6288      }
6289     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6290     resultspec.dsc$b_class = DSC$K_CLASS_D;
6291     resultspec.dsc$a_pointer = NULL;
6292     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6293       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6294     if (!isunix || !filespec.dsc$a_pointer)
6295       filespec.dsc$a_pointer = item;
6296     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6297     /*
6298      * Only return version specs, if the caller specified a version
6299      */
6300     had_version = strchr(item, ';');
6301     /*
6302      * Only return device and directory specs, if the caller specifed either.
6303      */
6304     had_device = strchr(item, ':');
6305     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6306
6307     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
6308                                   &defaultspec, 0, 0, &zero))))
6309         {
6310         char *string;
6311         char *c;
6312
6313         Newx(string,resultspec.dsc$w_length+1,char);
6314         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6315         string[resultspec.dsc$w_length] = '\0';
6316         if (NULL == had_version)
6317             *(strrchr(string, ';')) = '\0';
6318         if ((!had_directory) && (had_device == NULL))
6319             {
6320             if (NULL == (devdir = strrchr(string, ']')))
6321                 devdir = strrchr(string, '>');
6322             strcpy(string, devdir + 1);
6323             }
6324         /*
6325          * Be consistent with what the C RTL has already done to the rest of
6326          * the argv items and lowercase all of these names.
6327          */
6328         if (!decc_efs_case_preserve) {
6329             for (c = string; *c; ++c)
6330             if (isupper(*c))
6331                 *c = tolower(*c);
6332         }
6333         if (isunix) trim_unixpath(string,item,1);
6334         add_item(head, tail, string, count);
6335         ++expcount;
6336         }
6337     if (sts != RMS$_NMF)
6338         {
6339         set_vaxc_errno(sts);
6340         switch (sts)
6341             {
6342             case RMS$_FNF: case RMS$_DNF:
6343                 set_errno(ENOENT); break;
6344             case RMS$_DIR:
6345                 set_errno(ENOTDIR); break;
6346             case RMS$_DEV:
6347                 set_errno(ENODEV); break;
6348             case RMS$_FNM: case RMS$_SYN:
6349                 set_errno(EINVAL); break;
6350             case RMS$_PRV:
6351                 set_errno(EACCES); break;
6352             default:
6353                 _ckvmssts_noperl(sts);
6354             }
6355         }
6356     if (expcount == 0)
6357         add_item(head, tail, item, count);
6358     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6359     _ckvmssts_noperl(lib$find_file_end(&context));
6360 }
6361
6362 static int child_st[2];/* Event Flag set when child process completes   */
6363
6364 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6365
6366 static unsigned long int exit_handler(int *status)
6367 {
6368 short iosb[4];
6369
6370     if (0 == child_st[0])
6371         {
6372 #ifdef ARGPROC_DEBUG
6373         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6374 #endif
6375         fflush(stdout);     /* Have to flush pipe for binary data to    */
6376                             /* terminate properly -- <tp@mccall.com>    */
6377         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6378         sys$dassgn(child_chan);
6379         fclose(stdout);
6380         sys$synch(0, child_st);
6381         }
6382     return(1);
6383 }
6384
6385 static void sig_child(int chan)
6386 {
6387 #ifdef ARGPROC_DEBUG
6388     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6389 #endif
6390     if (child_st[0] == 0)
6391         child_st[0] = 1;
6392 }
6393
6394 static struct exit_control_block exit_block =
6395     {
6396     0,
6397     exit_handler,
6398     1,
6399     &exit_block.exit_status,
6400     0
6401     };
6402
6403 static void
6404 pipe_and_fork(pTHX_ char **cmargv)
6405 {
6406     PerlIO *fp;
6407     struct dsc$descriptor_s *vmscmd;
6408     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6409     int sts, j, l, ismcr, quote, tquote = 0;
6410
6411     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6412     vms_execfree(vmscmd);
6413
6414     j = l = 0;
6415     p = subcmd;
6416     q = cmargv[0];
6417     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6418               && toupper(*(q+2)) == 'R' && !*(q+3);
6419
6420     while (q && l < MAX_DCL_LINE_LENGTH) {
6421         if (!*q) {
6422             if (j > 0 && quote) {
6423                 *p++ = '"';
6424                 l++;
6425             }
6426             q = cmargv[++j];
6427             if (q) {
6428                 if (ismcr && j > 1) quote = 1;
6429                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6430                 *p++ = ' ';
6431                 l++;
6432                 if (quote || tquote) {
6433                     *p++ = '"';
6434                     l++;
6435                 }
6436         }
6437         } else {
6438             if ((quote||tquote) && *q == '"') {
6439                 *p++ = '"';
6440                 l++;
6441         }
6442             *p++ = *q++;
6443             l++;
6444         }
6445     }
6446     *p = '\0';
6447
6448     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
6449     if (fp == Nullfp) {
6450         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
6451         }
6452 }
6453
6454 static int background_process(pTHX_ int argc, char **argv)
6455 {
6456 char command[2048] = "$";
6457 $DESCRIPTOR(value, "");
6458 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
6459 static $DESCRIPTOR(null, "NLA0:");
6460 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
6461 char pidstring[80];
6462 $DESCRIPTOR(pidstr, "");
6463 int pid;
6464 unsigned long int flags = 17, one = 1, retsts;
6465
6466     strcat(command, argv[0]);
6467     while (--argc)
6468         {
6469         strcat(command, " \"");
6470         strcat(command, *(++argv));
6471         strcat(command, "\"");
6472         }
6473     value.dsc$a_pointer = command;
6474     value.dsc$w_length = strlen(value.dsc$a_pointer);
6475     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
6476     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
6477     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
6478         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
6479     }
6480     else {
6481         _ckvmssts_noperl(retsts);
6482     }
6483 #ifdef ARGPROC_DEBUG
6484     PerlIO_printf(Perl_debug_log, "%s\n", command);
6485 #endif
6486     sprintf(pidstring, "%08X", pid);
6487     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
6488     pidstr.dsc$a_pointer = pidstring;
6489     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
6490     lib$set_symbol(&pidsymbol, &pidstr);
6491     return(SS$_NORMAL);
6492 }
6493 /*}}}*/
6494 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
6495
6496
6497 /* OS-specific initialization at image activation (not thread startup) */
6498 /* Older VAXC header files lack these constants */
6499 #ifndef JPI$_RIGHTS_SIZE
6500 #  define JPI$_RIGHTS_SIZE 817
6501 #endif
6502 #ifndef KGB$M_SUBSYSTEM
6503 #  define KGB$M_SUBSYSTEM 0x8
6504 #endif
6505
6506 /*{{{void vms_image_init(int *, char ***)*/
6507 void
6508 vms_image_init(int *argcp, char ***argvp)
6509 {
6510   char eqv[LNM$C_NAMLENGTH+1] = "";
6511   unsigned int len, tabct = 8, tabidx = 0;
6512   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
6513   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
6514   unsigned short int dummy, rlen;
6515   struct dsc$descriptor_s **tabvec;
6516 #if defined(PERL_IMPLICIT_CONTEXT)
6517   pTHX = NULL;
6518 #endif
6519   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
6520                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
6521                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
6522                                  {          0,                0,    0,      0} };
6523
6524 #ifdef KILL_BY_SIGPRC
6525     Perl_csighandler_init();
6526 #endif
6527
6528   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
6529   _ckvmssts_noperl(iosb[0]);
6530   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
6531     if (iprv[i]) {           /* Running image installed with privs? */
6532       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
6533       will_taint = TRUE;
6534       break;
6535     }
6536   }
6537   /* Rights identifiers might trigger tainting as well. */
6538   if (!will_taint && (rlen || rsz)) {
6539     while (rlen < rsz) {
6540       /* We didn't get all the identifiers on the first pass.  Allocate a
6541        * buffer much larger than $GETJPI wants (rsz is size in bytes that
6542        * were needed to hold all identifiers at time of last call; we'll
6543        * allocate that many unsigned long ints), and go back and get 'em.
6544        * If it gave us less than it wanted to despite ample buffer space,
6545        * something's broken.  Is your system missing a system identifier?
6546        */
6547       if (rsz <= jpilist[1].buflen) {
6548          /* Perl_croak accvios when used this early in startup. */
6549          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
6550                          rsz, (unsigned long) jpilist[1].buflen,
6551                          "Check your rights database for corruption.\n");
6552          exit(SS$_ABORT);
6553       }
6554       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
6555       jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
6556       jpilist[1].buflen = rsz * sizeof(unsigned long int);
6557       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
6558       _ckvmssts_noperl(iosb[0]);
6559     }
6560     mask = jpilist[1].bufadr;
6561     /* Check attribute flags for each identifier (2nd longword); protected
6562      * subsystem identifiers trigger tainting.
6563      */
6564     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
6565       if (mask[i] & KGB$M_SUBSYSTEM) {
6566         will_taint = TRUE;
6567         break;
6568       }
6569     }
6570     if (mask != rlst) Safefree(mask);
6571   }
6572
6573   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
6574    * logical, some versions of the CRTL will add a phanthom /000000/
6575    * directory.  This needs to be removed.
6576    */
6577   if (decc_filename_unix_report) {
6578   char * zeros;
6579   int ulen;
6580     ulen = strlen(argvp[0][0]);
6581     if (ulen > 7) {
6582       zeros = strstr(argvp[0][0], "/000000/");
6583       if (zeros != NULL) {
6584         int mlen;
6585         mlen = ulen - (zeros - argvp[0][0]) - 7;
6586         memmove(zeros, &zeros[7], mlen);
6587         ulen = ulen - 7;
6588         argvp[0][0][ulen] = '\0';
6589       }
6590     }
6591     /* It also may have a trailing dot that needs to be removed otherwise
6592      * it will be converted to VMS mode incorrectly.
6593      */
6594     ulen--;
6595     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
6596       argvp[0][0][ulen] = '\0';
6597   }
6598
6599   /* We need to use this hack to tell Perl it should run with tainting,
6600    * since its tainting flag may be part of the PL_curinterp struct, which
6601    * hasn't been allocated when vms_image_init() is called.
6602    */
6603   if (will_taint) {
6604     char **newargv, **oldargv;
6605     oldargv = *argvp;
6606     Newx(newargv,(*argcp)+2,char *);
6607     newargv[0] = oldargv[0];
6608     Newx(newargv[1],3,char);
6609     strcpy(newargv[1], "-T");
6610     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
6611     (*argcp)++;
6612     newargv[*argcp] = NULL;
6613     /* We orphan the old argv, since we don't know where it's come from,
6614      * so we don't know how to free it.
6615      */
6616     *argvp = newargv;
6617   }
6618   else {  /* Did user explicitly request tainting? */
6619     int i;
6620     char *cp, **av = *argvp;
6621     for (i = 1; i < *argcp; i++) {
6622       if (*av[i] != '-') break;
6623       for (cp = av[i]+1; *cp; cp++) {
6624         if (*cp == 'T') { will_taint = 1; break; }
6625         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
6626                   strchr("DFIiMmx",*cp)) break;
6627       }
6628       if (will_taint) break;
6629     }
6630   }
6631
6632   for (tabidx = 0;
6633        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
6634        tabidx++) {
6635     if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
6636     else if (tabidx >= tabct) {
6637       tabct += 8;
6638       Renew(tabvec,tabct,struct dsc$descriptor_s *);
6639     }
6640     Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
6641     tabvec[tabidx]->dsc$w_length  = 0;
6642     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
6643     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
6644     tabvec[tabidx]->dsc$a_pointer = NULL;
6645     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
6646   }
6647   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
6648
6649   getredirection(argcp,argvp);
6650 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
6651   {
6652 # include <reentrancy.h>
6653   decc$set_reentrancy(C$C_MULTITHREAD);
6654   }
6655 #endif
6656   return;
6657 }
6658 /*}}}*/
6659
6660
6661 /* trim_unixpath()
6662  * Trim Unix-style prefix off filespec, so it looks like what a shell
6663  * glob expansion would return (i.e. from specified prefix on, not
6664  * full path).  Note that returned filespec is Unix-style, regardless
6665  * of whether input filespec was VMS-style or Unix-style.
6666  *
6667  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
6668  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
6669  * vector of options; at present, only bit 0 is used, and if set tells
6670  * trim unixpath to try the current default directory as a prefix when
6671  * presented with a possibly ambiguous ... wildcard.
6672  *
6673  * Returns !=0 on success, with trimmed filespec replacing contents of
6674  * fspec, and 0 on failure, with contents of fpsec unchanged.
6675  */
6676 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
6677 int
6678 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
6679 {
6680   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
6681        *template, *base, *end, *cp1, *cp2;
6682   register int tmplen, reslen = 0, dirs = 0;
6683
6684   if (!wildspec || !fspec) return 0;
6685   template = unixwild;
6686   if (strpbrk(wildspec,"]>:") != NULL) {
6687     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
6688   }
6689   else {
6690     strncpy(unixwild, wildspec, NAM$C_MAXRSS);
6691     unixwild[NAM$C_MAXRSS] = 0;
6692   }
6693   if (strpbrk(fspec,"]>:") != NULL) {
6694     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
6695     else base = unixified;
6696     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
6697      * check to see that final result fits into (isn't longer than) fspec */
6698     reslen = strlen(fspec);
6699   }
6700   else base = fspec;
6701
6702   /* No prefix or absolute path on wildcard, so nothing to remove */
6703   if (!*template || *template == '/') {
6704     if (base == fspec) return 1;
6705     tmplen = strlen(unixified);
6706     if (tmplen > reslen) return 0;  /* not enough space */
6707     /* Copy unixified resultant, including trailing NUL */
6708     memmove(fspec,unixified,tmplen+1);
6709     return 1;
6710   }
6711
6712   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
6713   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
6714     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
6715     for (cp1 = end ;cp1 >= base; cp1--)
6716       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
6717         { cp1++; break; }
6718     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
6719     return 1;
6720   }
6721   else {
6722     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
6723     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
6724     int ells = 1, totells, segdirs, match;
6725     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
6726                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6727
6728     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
6729     totells = ells;
6730     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
6731     if (ellipsis == template && opts & 1) {
6732       /* Template begins with an ellipsis.  Since we can't tell how many
6733        * directory names at the front of the resultant to keep for an
6734        * arbitrary starting point, we arbitrarily choose the current
6735        * default directory as a starting point.  If it's there as a prefix,
6736        * clip it off.  If not, fall through and act as if the leading
6737        * ellipsis weren't there (i.e. return shortest possible path that
6738        * could match template).
6739        */
6740       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
6741       if (!decc_efs_case_preserve) {
6742         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
6743           if (_tolower(*cp1) != _tolower(*cp2)) break;
6744       }
6745       segdirs = dirs - totells;  /* Min # of dirs we must have left */
6746       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
6747       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
6748         memcpy(fspec,cp2+1,end - cp2);
6749         return 1;
6750       }
6751     }
6752     /* First off, back up over constant elements at end of path */
6753     if (dirs) {
6754       for (front = end ; front >= base; front--)
6755          if (*front == '/' && !dirs--) { front++; break; }
6756     }
6757     if (!decc_efs_case_preserve) {
6758       for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
6759          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
6760     }
6761     if (cp1 != '\0') return 0;  /* Path too long. */
6762     lcend = cp2;
6763     *cp2 = '\0';  /* Pick up with memcpy later */
6764     lcfront = lcres + (front - base);
6765     /* Now skip over each ellipsis and try to match the path in front of it. */
6766     while (ells--) {
6767       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
6768         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
6769             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
6770       if (cp1 < template) break; /* template started with an ellipsis */
6771       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
6772         ellipsis = cp1; continue;
6773       }
6774       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
6775       nextell = cp1;
6776       for (segdirs = 0, cp2 = tpl;
6777            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
6778            cp1++, cp2++) {
6779          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
6780          else {
6781             if (!decc_efs_case_preserve) {
6782               *cp2 = _tolower(*cp1);  /* else lowercase for match */
6783             }
6784             else {
6785               *cp2 = *cp1;  /* else preserve case for match */
6786             }
6787          }
6788          if (*cp2 == '/') segdirs++;
6789       }
6790       if (cp1 != ellipsis - 1) return 0; /* Path too long */
6791       /* Back up at least as many dirs as in template before matching */
6792       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
6793         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
6794       for (match = 0; cp1 > lcres;) {
6795         resdsc.dsc$a_pointer = cp1;
6796         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
6797           match++;
6798           if (match == 1) lcfront = cp1;
6799         }
6800         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
6801       }
6802       if (!match) return 0;  /* Can't find prefix ??? */
6803       if (match > 1 && opts & 1) {
6804         /* This ... wildcard could cover more than one set of dirs (i.e.
6805          * a set of similar dir names is repeated).  If the template
6806          * contains more than 1 ..., upstream elements could resolve the
6807          * ambiguity, but it's not worth a full backtracking setup here.
6808          * As a quick heuristic, clip off the current default directory
6809          * if it's present to find the trimmed spec, else use the
6810          * shortest string that this ... could cover.
6811          */
6812         char def[NAM$C_MAXRSS+1], *st;
6813
6814         if (getcwd(def, sizeof def,0) == NULL) return 0;
6815         if (!decc_efs_case_preserve) {
6816           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
6817             if (_tolower(*cp1) != _tolower(*cp2)) break;
6818         }
6819         segdirs = dirs - totells;  /* Min # of dirs we must have left */
6820         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
6821         if (*cp1 == '\0' && *cp2 == '/') {
6822           memcpy(fspec,cp2+1,end - cp2);
6823           return 1;
6824         }
6825         /* Nope -- stick with lcfront from above and keep going. */
6826       }
6827     }
6828     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
6829     return 1;
6830     ellipsis = nextell;
6831   }
6832
6833 }  /* end of trim_unixpath() */
6834 /*}}}*/
6835
6836
6837 /*
6838  *  VMS readdir() routines.
6839  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
6840  *
6841  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
6842  *  Minor modifications to original routines.
6843  */
6844
6845 /* readdir may have been redefined by reentr.h, so make sure we get
6846  * the local version for what we do here.
6847  */
6848 #ifdef readdir
6849 # undef readdir
6850 #endif
6851 #if !defined(PERL_IMPLICIT_CONTEXT)
6852 # define readdir Perl_readdir
6853 #else
6854 # define readdir(a) Perl_readdir(aTHX_ a)
6855 #endif
6856
6857     /* Number of elements in vms_versions array */
6858 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
6859
6860 /*
6861  *  Open a directory, return a handle for later use.
6862  */
6863 /*{{{ DIR *opendir(char*name) */
6864 MY_DIR *
6865 Perl_opendir(pTHX_ const char *name)
6866 {
6867     MY_DIR *dd;
6868     char dir[NAM$C_MAXRSS+1];
6869     Stat_t sb;
6870
6871     if (do_tovmspath(name,dir,0) == NULL) {
6872       return NULL;
6873     }
6874     /* Check access before stat; otherwise stat does not
6875      * accurately report whether it's a directory.
6876      */
6877     if (!cando_by_name(S_IRUSR,0,dir)) {
6878       /* cando_by_name has already set errno */
6879       return NULL;
6880     }
6881     if (flex_stat(dir,&sb) == -1) return NULL;
6882     if (!S_ISDIR(sb.st_mode)) {
6883       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
6884       return NULL;
6885     }
6886     /* Get memory for the handle, and the pattern. */
6887     Newx(dd,1,MY_DIR);
6888     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
6889
6890     /* Fill in the fields; mainly playing with the descriptor. */
6891     sprintf(dd->pattern, "%s*.*",dir);
6892     dd->context = 0;
6893     dd->count = 0;
6894     dd->vms_wantversions = 0;
6895     dd->pat.dsc$a_pointer = dd->pattern;
6896     dd->pat.dsc$w_length = strlen(dd->pattern);
6897     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
6898     dd->pat.dsc$b_class = DSC$K_CLASS_S;
6899 #if defined(USE_ITHREADS)
6900     Newx(dd->mutex,1,perl_mutex);
6901     MUTEX_INIT( (perl_mutex *) dd->mutex );
6902 #else
6903     dd->mutex = NULL;
6904 #endif
6905
6906     return dd;
6907 }  /* end of opendir() */
6908 /*}}}*/
6909
6910 /*
6911  *  Set the flag to indicate we want versions or not.
6912  */
6913 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
6914 void
6915 vmsreaddirversions(MY_DIR *dd, int flag)
6916 {
6917     dd->vms_wantversions = flag;
6918 }
6919 /*}}}*/
6920
6921 /*
6922  *  Free up an opened directory.
6923  */
6924 /*{{{ void closedir(DIR *dd)*/
6925 void
6926 Perl_closedir(MY_DIR *dd)
6927 {
6928     int sts;
6929
6930     sts = lib$find_file_end(&dd->context);
6931     Safefree(dd->pattern);
6932 #if defined(USE_ITHREADS)
6933     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
6934     Safefree(dd->mutex);
6935 #endif
6936     Safefree(dd);
6937 }
6938 /*}}}*/
6939
6940 /*
6941  *  Collect all the version numbers for the current file.
6942  */
6943 static void
6944 collectversions(pTHX_ MY_DIR *dd)
6945 {
6946     struct dsc$descriptor_s     pat;
6947     struct dsc$descriptor_s     res;
6948     struct my_dirent *e;
6949     char *p, *text, buff[sizeof dd->entry.d_name];
6950     int i;
6951     unsigned long context, tmpsts;
6952
6953     /* Convenient shorthand. */
6954     e = &dd->entry;
6955
6956     /* Add the version wildcard, ignoring the "*.*" put on before */
6957     i = strlen(dd->pattern);
6958     Newx(text,i + e->d_namlen + 3,char);
6959     strcpy(text, dd->pattern);
6960     sprintf(&text[i - 3], "%s;*", e->d_name);
6961
6962     /* Set up the pattern descriptor. */
6963     pat.dsc$a_pointer = text;
6964     pat.dsc$w_length = i + e->d_namlen - 1;
6965     pat.dsc$b_dtype = DSC$K_DTYPE_T;
6966     pat.dsc$b_class = DSC$K_CLASS_S;
6967
6968     /* Set up result descriptor. */
6969     res.dsc$a_pointer = buff;
6970     res.dsc$w_length = sizeof buff - 2;
6971     res.dsc$b_dtype = DSC$K_DTYPE_T;
6972     res.dsc$b_class = DSC$K_CLASS_S;
6973
6974     /* Read files, collecting versions. */
6975     for (context = 0, e->vms_verscount = 0;
6976          e->vms_verscount < VERSIZE(e);
6977          e->vms_verscount++) {
6978         tmpsts = lib$find_file(&pat, &res, &context);
6979         if (tmpsts == RMS$_NMF || context == 0) break;
6980         _ckvmssts(tmpsts);
6981         buff[sizeof buff - 1] = '\0';
6982         if ((p = strchr(buff, ';')))
6983             e->vms_versions[e->vms_verscount] = atoi(p + 1);
6984         else
6985             e->vms_versions[e->vms_verscount] = -1;
6986     }
6987
6988     _ckvmssts(lib$find_file_end(&context));
6989     Safefree(text);
6990
6991 }  /* end of collectversions() */
6992
6993 /*
6994  *  Read the next entry from the directory.
6995  */
6996 /*{{{ struct dirent *readdir(DIR *dd)*/
6997 struct my_dirent *
6998 Perl_readdir(pTHX_ MY_DIR *dd)
6999 {
7000     struct dsc$descriptor_s     res;
7001     char *p, buff[sizeof dd->entry.d_name];
7002     unsigned long int tmpsts;
7003
7004     /* Set up result descriptor, and get next file. */
7005     res.dsc$a_pointer = buff;
7006     res.dsc$w_length = sizeof buff - 2;
7007     res.dsc$b_dtype = DSC$K_DTYPE_T;
7008     res.dsc$b_class = DSC$K_CLASS_S;
7009     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7010     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7011     if (!(tmpsts & 1)) {
7012       set_vaxc_errno(tmpsts);
7013       switch (tmpsts) {
7014         case RMS$_PRV:
7015           set_errno(EACCES); break;
7016         case RMS$_DEV:
7017           set_errno(ENODEV); break;
7018         case RMS$_DIR:
7019           set_errno(ENOTDIR); break;
7020         case RMS$_FNF: case RMS$_DNF:
7021           set_errno(ENOENT); break;
7022         default:
7023           set_errno(EVMSERR);
7024       }
7025       return NULL;
7026     }
7027     dd->count++;
7028     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7029     if (!decc_efs_case_preserve) {
7030       buff[sizeof buff - 1] = '\0';
7031       for (p = buff; *p; p++) *p = _tolower(*p);
7032       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7033       *p = '\0';
7034     }
7035     else {
7036       /* we don't want to force to lowercase, just null terminate */
7037       buff[res.dsc$w_length] = '\0';
7038     }
7039     for (p = buff; *p; p++) *p = _tolower(*p);
7040     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7041     *p = '\0';
7042
7043     /* Skip any directory component and just copy the name. */
7044     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7045     else strcpy(dd->entry.d_name, buff);
7046
7047     /* Clobber the version. */
7048     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7049
7050     dd->entry.d_namlen = strlen(dd->entry.d_name);
7051     dd->entry.vms_verscount = 0;
7052     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7053     return &dd->entry;
7054
7055 }  /* end of readdir() */
7056 /*}}}*/
7057
7058 /*
7059  *  Read the next entry from the directory -- thread-safe version.
7060  */
7061 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7062 int
7063 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7064 {
7065     int retval;
7066
7067     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7068
7069     entry = Perl_readdir(dd);
7070     *result = entry;
7071     retval = ( *result == NULL ? errno : 0 );
7072
7073     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7074
7075     return retval;
7076
7077 }  /* end of readdir_r() */
7078 /*}}}*/
7079
7080 /*
7081  *  Return something that can be used in a seekdir later.
7082  */
7083 /*{{{ long telldir(DIR *dd)*/
7084 long
7085 Perl_telldir(MY_DIR *dd)
7086 {
7087     return dd->count;
7088 }
7089 /*}}}*/
7090
7091 /*
7092  *  Return to a spot where we used to be.  Brute force.
7093  */
7094 /*{{{ void seekdir(DIR *dd,long count)*/
7095 void
7096 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7097 {
7098     int vms_wantversions;
7099
7100     /* If we haven't done anything yet... */
7101     if (dd->count == 0)
7102         return;
7103
7104     /* Remember some state, and clear it. */
7105     vms_wantversions = dd->vms_wantversions;
7106     dd->vms_wantversions = 0;
7107     _ckvmssts(lib$find_file_end(&dd->context));
7108     dd->context = 0;
7109
7110     /* The increment is in readdir(). */
7111     for (dd->count = 0; dd->count < count; )
7112         readdir(dd);
7113
7114     dd->vms_wantversions = vms_wantversions;
7115
7116 }  /* end of seekdir() */
7117 /*}}}*/
7118
7119 /* VMS subprocess management
7120  *
7121  * my_vfork() - just a vfork(), after setting a flag to record that
7122  * the current script is trying a Unix-style fork/exec.
7123  *
7124  * vms_do_aexec() and vms_do_exec() are called in response to the
7125  * perl 'exec' function.  If this follows a vfork call, then they
7126  * call out the regular perl routines in doio.c which do an
7127  * execvp (for those who really want to try this under VMS).
7128  * Otherwise, they do exactly what the perl docs say exec should
7129  * do - terminate the current script and invoke a new command
7130  * (See below for notes on command syntax.)
7131  *
7132  * do_aspawn() and do_spawn() implement the VMS side of the perl
7133  * 'system' function.
7134  *
7135  * Note on command arguments to perl 'exec' and 'system': When handled
7136  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7137  * are concatenated to form a DCL command string.  If the first arg
7138  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7139  * the command string is handed off to DCL directly.  Otherwise,
7140  * the first token of the command is taken as the filespec of an image
7141  * to run.  The filespec is expanded using a default type of '.EXE' and
7142  * the process defaults for device, directory, etc., and if found, the resultant
7143  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7144  * the command string as parameters.  This is perhaps a bit complicated,
7145  * but I hope it will form a happy medium between what VMS folks expect
7146  * from lib$spawn and what Unix folks expect from exec.
7147  */
7148
7149 static int vfork_called;
7150
7151 /*{{{int my_vfork()*/
7152 int
7153 my_vfork()
7154 {
7155   vfork_called++;
7156   return vfork();
7157 }
7158 /*}}}*/
7159
7160
7161 static void
7162 vms_execfree(struct dsc$descriptor_s *vmscmd)
7163 {
7164   if (vmscmd) {
7165       if (vmscmd->dsc$a_pointer) {
7166           Safefree(vmscmd->dsc$a_pointer);
7167       }
7168       Safefree(vmscmd);
7169   }
7170 }
7171
7172 static char *
7173 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7174 {
7175   char *junk, *tmps = Nullch;
7176   register size_t cmdlen = 0;
7177   size_t rlen;
7178   register SV **idx;
7179   STRLEN n_a;
7180
7181   idx = mark;
7182   if (really) {
7183     tmps = SvPV(really,rlen);
7184     if (*tmps) {
7185       cmdlen += rlen + 1;
7186       idx++;
7187     }
7188   }
7189
7190   for (idx++; idx <= sp; idx++) {
7191     if (*idx) {
7192       junk = SvPVx(*idx,rlen);
7193       cmdlen += rlen ? rlen + 1 : 0;
7194     }
7195   }
7196   Newx(PL_Cmd,cmdlen+1,char);
7197
7198   if (tmps && *tmps) {
7199     strcpy(PL_Cmd,tmps);
7200     mark++;
7201   }
7202   else *PL_Cmd = '\0';
7203   while (++mark <= sp) {
7204     if (*mark) {
7205       char *s = SvPVx(*mark,n_a);
7206       if (!*s) continue;
7207       if (*PL_Cmd) strcat(PL_Cmd," ");
7208       strcat(PL_Cmd,s);
7209     }
7210   }
7211   return PL_Cmd;
7212
7213 }  /* end of setup_argstr() */
7214
7215
7216 static unsigned long int
7217 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7218                    struct dsc$descriptor_s **pvmscmd)
7219 {
7220   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7221   $DESCRIPTOR(defdsc,".EXE");
7222   $DESCRIPTOR(defdsc2,".");
7223   $DESCRIPTOR(resdsc,resspec);
7224   struct dsc$descriptor_s *vmscmd;
7225   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7226   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7227   register char *s, *rest, *cp, *wordbreak;
7228   char * cmd;
7229   int cmdlen;
7230   register int isdcl;
7231
7232   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7233
7234   /* Make a copy for modification */
7235   cmdlen = strlen(incmd);
7236   Newx(cmd, cmdlen+1, char);
7237   strncpy(cmd, incmd, cmdlen);
7238   cmd[cmdlen] = 0;
7239
7240   vmscmd->dsc$a_pointer = NULL;
7241   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7242   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7243   vmscmd->dsc$w_length = 0;
7244   if (pvmscmd) *pvmscmd = vmscmd;
7245
7246   if (suggest_quote) *suggest_quote = 0;
7247
7248   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7249     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7250     Safefree(cmd);
7251   }
7252
7253   s = cmd;
7254
7255   while (*s && isspace(*s)) s++;
7256
7257   if (*s == '@' || *s == '$') {
7258     vmsspec[0] = *s;  rest = s + 1;
7259     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7260   }
7261   else { cp = vmsspec; rest = s; }
7262   if (*rest == '.' || *rest == '/') {
7263     char *cp2;
7264     for (cp2 = resspec;
7265          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7266          rest++, cp2++) *cp2 = *rest;
7267     *cp2 = '\0';
7268     if (do_tovmsspec(resspec,cp,0)) {
7269       s = vmsspec;
7270       if (*rest) {
7271         for (cp2 = vmsspec + strlen(vmsspec);
7272              *rest && cp2 - vmsspec < sizeof vmsspec;
7273              rest++, cp2++) *cp2 = *rest;
7274         *cp2 = '\0';
7275       }
7276     }
7277   }
7278   /* Intuit whether verb (first word of cmd) is a DCL command:
7279    *   - if first nonspace char is '@', it's a DCL indirection
7280    * otherwise
7281    *   - if verb contains a filespec separator, it's not a DCL command
7282    *   - if it doesn't, caller tells us whether to default to a DCL
7283    *     command, or to a local image unless told it's DCL (by leading '$')
7284    */
7285   if (*s == '@') {
7286       isdcl = 1;
7287       if (suggest_quote) *suggest_quote = 1;
7288   } else {
7289     register char *filespec = strpbrk(s,":<[.;");
7290     rest = wordbreak = strpbrk(s," \"\t/");
7291     if (!wordbreak) wordbreak = s + strlen(s);
7292     if (*s == '$') check_img = 0;
7293     if (filespec && (filespec < wordbreak)) isdcl = 0;
7294     else isdcl = !check_img;
7295   }
7296
7297   if (!isdcl) {
7298     imgdsc.dsc$a_pointer = s;
7299     imgdsc.dsc$w_length = wordbreak - s;
7300     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7301     if (!(retsts&1)) {
7302         _ckvmssts(lib$find_file_end(&cxt));
7303         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7304       if (!(retsts & 1) && *s == '$') {
7305         _ckvmssts(lib$find_file_end(&cxt));
7306         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7307         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7308         if (!(retsts&1)) {
7309           _ckvmssts(lib$find_file_end(&cxt));
7310           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7311         }
7312       }
7313     }
7314     _ckvmssts(lib$find_file_end(&cxt));
7315
7316     if (retsts & 1) {
7317       FILE *fp;
7318       s = resspec;
7319       while (*s && !isspace(*s)) s++;
7320       *s = '\0';
7321
7322       /* check that it's really not DCL with no file extension */
7323       fp = fopen(resspec,"r","ctx=bin","shr=get");
7324       if (fp) {
7325         char b[256] = {0,0,0,0};
7326         read(fileno(fp), b, 256);
7327         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7328         if (isdcl) {
7329           /* Check for script */
7330           if ((b[0] == '#') && (b[1] == '!')) {
7331             /* Image is following after white space */
7332             /* It will need to be converted to VMS format and validated */
7333           }
7334         }
7335         fclose(fp);
7336       }
7337       if (check_img && isdcl) return RMS$_FNF;
7338
7339       if (cando_by_name(S_IXUSR,0,resspec)) {
7340         Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
7341         if (!isdcl) {
7342             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
7343             if (suggest_quote) *suggest_quote = 1;
7344         } else {
7345             strcpy(vmscmd->dsc$a_pointer,"@");
7346             if (suggest_quote) *suggest_quote = 1;
7347         }
7348         strcat(vmscmd->dsc$a_pointer,resspec);
7349         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
7350         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
7351         Safefree(cmd);
7352         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7353       }
7354       else retsts = RMS$_PRV;
7355     }
7356   }
7357   /* It's either a DCL command or we couldn't find a suitable image */
7358   vmscmd->dsc$w_length = strlen(cmd);
7359 /*  if (cmd == PL_Cmd) {
7360       vmscmd->dsc$a_pointer = PL_Cmd;
7361       if (suggest_quote) *suggest_quote = 1;
7362   }
7363   else  */
7364       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
7365
7366   Safefree(cmd);
7367
7368   /* check if it's a symbol (for quoting purposes) */
7369   if (suggest_quote && !*suggest_quote) {
7370     int iss;
7371     char equiv[LNM$C_NAMLENGTH];
7372     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7373     eqvdsc.dsc$a_pointer = equiv;
7374
7375     iss = lib$get_symbol(vmscmd,&eqvdsc);
7376     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
7377   }
7378   if (!(retsts & 1)) {
7379     /* just hand off status values likely to be due to user error */
7380     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
7381         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
7382        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
7383     else { _ckvmssts(retsts); }
7384   }
7385
7386   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7387
7388 }  /* end of setup_cmddsc() */
7389
7390
7391 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
7392 bool
7393 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
7394 {
7395   if (sp > mark) {
7396     if (vfork_called) {           /* this follows a vfork - act Unixish */
7397       vfork_called--;
7398       if (vfork_called < 0) {
7399         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7400         vfork_called = 0;
7401       }
7402       else return do_aexec(really,mark,sp);
7403     }
7404                                            /* no vfork - act VMSish */
7405     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
7406
7407   }
7408
7409   return FALSE;
7410 }  /* end of vms_do_aexec() */
7411 /*}}}*/
7412
7413 /* {{{bool vms_do_exec(char *cmd) */
7414 bool
7415 Perl_vms_do_exec(pTHX_ const char *cmd)
7416 {
7417   struct dsc$descriptor_s *vmscmd;
7418
7419   if (vfork_called) {             /* this follows a vfork - act Unixish */
7420     vfork_called--;
7421     if (vfork_called < 0) {
7422       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7423       vfork_called = 0;
7424     }
7425     else return do_exec(cmd);
7426   }
7427
7428   {                               /* no vfork - act VMSish */
7429     unsigned long int retsts;
7430
7431     TAINT_ENV();
7432     TAINT_PROPER("exec");
7433     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
7434       retsts = lib$do_command(vmscmd);
7435
7436     switch (retsts) {
7437       case RMS$_FNF: case RMS$_DNF:
7438         set_errno(ENOENT); break;
7439       case RMS$_DIR:
7440         set_errno(ENOTDIR); break;
7441       case RMS$_DEV:
7442         set_errno(ENODEV); break;
7443       case RMS$_PRV:
7444         set_errno(EACCES); break;
7445       case RMS$_SYN:
7446         set_errno(EINVAL); break;
7447       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7448         set_errno(E2BIG); break;
7449       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7450         _ckvmssts(retsts); /* fall through */
7451       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7452         set_errno(EVMSERR);
7453     }
7454     set_vaxc_errno(retsts);
7455     if (ckWARN(WARN_EXEC)) {
7456       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
7457              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
7458     }
7459     vms_execfree(vmscmd);
7460   }
7461
7462   return FALSE;
7463
7464 }  /* end of vms_do_exec() */
7465 /*}}}*/
7466
7467 unsigned long int Perl_do_spawn(pTHX_ const char *);
7468
7469 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
7470 unsigned long int
7471 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
7472 {
7473   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
7474
7475   return SS$_ABORT;
7476 }  /* end of do_aspawn() */
7477 /*}}}*/
7478
7479 /* {{{unsigned long int do_spawn(char *cmd) */
7480 unsigned long int
7481 Perl_do_spawn(pTHX_ const char *cmd)
7482 {
7483   unsigned long int sts, substs;
7484
7485   TAINT_ENV();
7486   TAINT_PROPER("spawn");
7487   if (!cmd || !*cmd) {
7488     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
7489     if (!(sts & 1)) {
7490       switch (sts) {
7491         case RMS$_FNF:  case RMS$_DNF:
7492           set_errno(ENOENT); break;
7493         case RMS$_DIR:
7494           set_errno(ENOTDIR); break;
7495         case RMS$_DEV:
7496           set_errno(ENODEV); break;
7497         case RMS$_PRV:
7498           set_errno(EACCES); break;
7499         case RMS$_SYN:
7500           set_errno(EINVAL); break;
7501         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7502           set_errno(E2BIG); break;
7503         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7504           _ckvmssts(sts); /* fall through */
7505         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7506           set_errno(EVMSERR);
7507       }
7508       set_vaxc_errno(sts);
7509       if (ckWARN(WARN_EXEC)) {
7510         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
7511                     Strerror(errno));
7512       }
7513     }
7514     sts = substs;
7515   }
7516   else {
7517     PerlIO * fp;
7518     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
7519     if (fp != NULL)
7520       my_pclose(fp);
7521   }
7522   return sts;
7523 }  /* end of do_spawn() */
7524 /*}}}*/
7525
7526
7527 static unsigned int *sockflags, sockflagsize;
7528
7529 /*
7530  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
7531  * routines found in some versions of the CRTL can't deal with sockets.
7532  * We don't shim the other file open routines since a socket isn't
7533  * likely to be opened by a name.
7534  */
7535 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
7536 FILE *my_fdopen(int fd, const char *mode)
7537 {
7538   FILE *fp = fdopen(fd, mode);
7539
7540   if (fp) {
7541     unsigned int fdoff = fd / sizeof(unsigned int);
7542     Stat_t sbuf; /* native stat; we don't need flex_stat */
7543     if (!sockflagsize || fdoff > sockflagsize) {
7544       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
7545       else           Newx  (sockflags,fdoff+2,unsigned int);
7546       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
7547       sockflagsize = fdoff + 2;
7548     }
7549     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
7550       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
7551   }
7552   return fp;
7553
7554 }
7555 /*}}}*/
7556
7557
7558 /*
7559  * Clear the corresponding bit when the (possibly) socket stream is closed.
7560  * There still a small hole: we miss an implicit close which might occur
7561  * via freopen().  >> Todo
7562  */
7563 /*{{{ int my_fclose(FILE *fp)*/
7564 int my_fclose(FILE *fp) {
7565   if (fp) {
7566     unsigned int fd = fileno(fp);
7567     unsigned int fdoff = fd / sizeof(unsigned int);
7568
7569     if (sockflagsize && fdoff <= sockflagsize)
7570       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
7571   }
7572   return fclose(fp);
7573 }
7574 /*}}}*/
7575
7576
7577 /*
7578  * A simple fwrite replacement which outputs itmsz*nitm chars without
7579  * introducing record boundaries every itmsz chars.
7580  * We are using fputs, which depends on a terminating null.  We may
7581  * well be writing binary data, so we need to accommodate not only
7582  * data with nulls sprinkled in the middle but also data with no null
7583  * byte at the end.
7584  */
7585 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
7586 int
7587 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
7588 {
7589   register char *cp, *end, *cpd, *data;
7590   register unsigned int fd = fileno(dest);
7591   register unsigned int fdoff = fd / sizeof(unsigned int);
7592   int retval;
7593   int bufsize = itmsz * nitm + 1;
7594
7595   if (fdoff < sockflagsize &&
7596       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
7597     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
7598     return nitm;
7599   }
7600
7601   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
7602   memcpy( data, src, itmsz*nitm );
7603   data[itmsz*nitm] = '\0';
7604
7605   end = data + itmsz * nitm;
7606   retval = (int) nitm; /* on success return # items written */
7607
7608   cpd = data;
7609   while (cpd <= end) {
7610     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
7611     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
7612     if (cp < end)
7613       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
7614     cpd = cp + 1;
7615   }
7616
7617   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
7618   return retval;
7619
7620 }  /* end of my_fwrite() */
7621 /*}}}*/
7622
7623 /*{{{ int my_flush(FILE *fp)*/
7624 int
7625 Perl_my_flush(pTHX_ FILE *fp)
7626 {
7627     int res;
7628     if ((res = fflush(fp)) == 0 && fp) {
7629 #ifdef VMS_DO_SOCKETS
7630         Stat_t s;
7631         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
7632 #endif
7633             res = fsync(fileno(fp));
7634     }
7635 /*
7636  * If the flush succeeded but set end-of-file, we need to clear
7637  * the error because our caller may check ferror().  BTW, this
7638  * probably means we just flushed an empty file.
7639  */
7640     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
7641
7642     return res;
7643 }
7644 /*}}}*/
7645
7646 /*
7647  * Here are replacements for the following Unix routines in the VMS environment:
7648  *      getpwuid    Get information for a particular UIC or UID
7649  *      getpwnam    Get information for a named user
7650  *      getpwent    Get information for each user in the rights database
7651  *      setpwent    Reset search to the start of the rights database
7652  *      endpwent    Finish searching for users in the rights database
7653  *
7654  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
7655  * (defined in pwd.h), which contains the following fields:-
7656  *      struct passwd {
7657  *              char        *pw_name;    Username (in lower case)
7658  *              char        *pw_passwd;  Hashed password
7659  *              unsigned int pw_uid;     UIC
7660  *              unsigned int pw_gid;     UIC group  number
7661  *              char        *pw_unixdir; Default device/directory (VMS-style)
7662  *              char        *pw_gecos;   Owner name
7663  *              char        *pw_dir;     Default device/directory (Unix-style)
7664  *              char        *pw_shell;   Default CLI name (eg. DCL)
7665  *      };
7666  * If the specified user does not exist, getpwuid and getpwnam return NULL.
7667  *
7668  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
7669  * not the UIC member number (eg. what's returned by getuid()),
7670  * getpwuid() can accept either as input (if uid is specified, the caller's
7671  * UIC group is used), though it won't recognise gid=0.
7672  *
7673  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
7674  * information about other users in your group or in other groups, respectively.
7675  * If the required privilege is not available, then these routines fill only
7676  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
7677  * string).
7678  *
7679  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
7680  */
7681
7682 /* sizes of various UAF record fields */
7683 #define UAI$S_USERNAME 12
7684 #define UAI$S_IDENT    31
7685 #define UAI$S_OWNER    31
7686 #define UAI$S_DEFDEV   31
7687 #define UAI$S_DEFDIR   63
7688 #define UAI$S_DEFCLI   31
7689 #define UAI$S_PWD       8
7690
7691 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
7692                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
7693                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
7694
7695 static char __empty[]= "";
7696 static struct passwd __passwd_empty=
7697     {(char *) __empty, (char *) __empty, 0, 0,
7698      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
7699 static int contxt= 0;
7700 static struct passwd __pwdcache;
7701 static char __pw_namecache[UAI$S_IDENT+1];
7702
7703 /*
7704  * This routine does most of the work extracting the user information.
7705  */
7706 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
7707 {
7708     static struct {
7709         unsigned char length;
7710         char pw_gecos[UAI$S_OWNER+1];
7711     } owner;
7712     static union uicdef uic;
7713     static struct {
7714         unsigned char length;
7715         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
7716     } defdev;
7717     static struct {
7718         unsigned char length;
7719         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
7720     } defdir;
7721     static struct {
7722         unsigned char length;
7723         char pw_shell[UAI$S_DEFCLI+1];
7724     } defcli;
7725     static char pw_passwd[UAI$S_PWD+1];
7726
7727     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
7728     struct dsc$descriptor_s name_desc;
7729     unsigned long int sts;
7730
7731     static struct itmlst_3 itmlst[]= {
7732         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
7733         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
7734         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
7735         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
7736         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
7737         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
7738         {0,                0,           NULL,    NULL}};
7739
7740     name_desc.dsc$w_length=  strlen(name);
7741     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
7742     name_desc.dsc$b_class=   DSC$K_CLASS_S;
7743     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
7744
7745 /*  Note that sys$getuai returns many fields as counted strings. */
7746     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
7747     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
7748       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
7749     }
7750     else { _ckvmssts(sts); }
7751     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
7752
7753     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
7754     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
7755     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
7756     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
7757     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
7758     owner.pw_gecos[lowner]=            '\0';
7759     defdev.pw_dir[ldefdev+ldefdir]= '\0';
7760     defcli.pw_shell[ldefcli]=          '\0';
7761     if (valid_uic(uic)) {
7762         pwd->pw_uid= uic.uic$l_uic;
7763         pwd->pw_gid= uic.uic$v_group;
7764     }
7765     else
7766       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
7767     pwd->pw_passwd=  pw_passwd;
7768     pwd->pw_gecos=   owner.pw_gecos;
7769     pwd->pw_dir=     defdev.pw_dir;
7770     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
7771     pwd->pw_shell=   defcli.pw_shell;
7772     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
7773         int ldir;
7774         ldir= strlen(pwd->pw_unixdir) - 1;
7775         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
7776     }
7777     else
7778         strcpy(pwd->pw_unixdir, pwd->pw_dir);
7779     if (!decc_efs_case_preserve)
7780         __mystrtolower(pwd->pw_unixdir);
7781     return 1;
7782 }
7783
7784 /*
7785  * Get information for a named user.
7786 */
7787 /*{{{struct passwd *getpwnam(char *name)*/
7788 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
7789 {
7790     struct dsc$descriptor_s name_desc;
7791     union uicdef uic;
7792     unsigned long int status, sts;
7793
7794     __pwdcache = __passwd_empty;
7795     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
7796       /* We still may be able to determine pw_uid and pw_gid */
7797       name_desc.dsc$w_length=  strlen(name);
7798       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
7799       name_desc.dsc$b_class=   DSC$K_CLASS_S;
7800       name_desc.dsc$a_pointer= (char *) name;
7801       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
7802         __pwdcache.pw_uid= uic.uic$l_uic;
7803         __pwdcache.pw_gid= uic.uic$v_group;
7804       }
7805       else {
7806         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
7807           set_vaxc_errno(sts);
7808           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
7809           return NULL;
7810         }
7811         else { _ckvmssts(sts); }
7812       }
7813     }
7814     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
7815     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
7816     __pwdcache.pw_name= __pw_namecache;
7817     return &__pwdcache;
7818 }  /* end of my_getpwnam() */
7819 /*}}}*/
7820
7821 /*
7822  * Get information for a particular UIC or UID.
7823  * Called by my_getpwent with uid=-1 to list all users.
7824 */
7825 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
7826 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
7827 {
7828     const $DESCRIPTOR(name_desc,__pw_namecache);
7829     unsigned short lname;
7830     union uicdef uic;
7831     unsigned long int status;
7832
7833     if (uid == (unsigned int) -1) {
7834       do {
7835         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
7836         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
7837           set_vaxc_errno(status);
7838           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
7839           my_endpwent();
7840           return NULL;
7841         }
7842         else { _ckvmssts(status); }
7843       } while (!valid_uic (uic));
7844     }
7845     else {
7846       uic.uic$l_uic= uid;
7847       if (!uic.uic$v_group)
7848         uic.uic$v_group= PerlProc_getgid();
7849       if (valid_uic(uic))
7850         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
7851       else status = SS$_IVIDENT;
7852       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
7853           status == RMS$_PRV) {
7854         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
7855         return NULL;
7856       }
7857       else { _ckvmssts(status); }
7858     }
7859     __pw_namecache[lname]= '\0';
7860     __mystrtolower(__pw_namecache);
7861
7862     __pwdcache = __passwd_empty;
7863     __pwdcache.pw_name = __pw_namecache;
7864
7865 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
7866     The identifier's value is usually the UIC, but it doesn't have to be,
7867     so if we can, we let fillpasswd update this. */
7868     __pwdcache.pw_uid =  uic.uic$l_uic;
7869     __pwdcache.pw_gid =  uic.uic$v_group;
7870
7871     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
7872     return &__pwdcache;
7873
7874 }  /* end of my_getpwuid() */
7875 /*}}}*/
7876
7877 /*
7878  * Get information for next user.
7879 */
7880 /*{{{struct passwd *my_getpwent()*/
7881 struct passwd *Perl_my_getpwent(pTHX)
7882 {
7883     return (my_getpwuid((unsigned int) -1));
7884 }
7885 /*}}}*/
7886
7887 /*
7888  * Finish searching rights database for users.
7889 */
7890 /*{{{void my_endpwent()*/
7891 void Perl_my_endpwent(pTHX)
7892 {
7893     if (contxt) {
7894       _ckvmssts(sys$finish_rdb(&contxt));
7895       contxt= 0;
7896     }
7897 }
7898 /*}}}*/
7899
7900 #ifdef HOMEGROWN_POSIX_SIGNALS
7901   /* Signal handling routines, pulled into the core from POSIX.xs.
7902    *
7903    * We need these for threads, so they've been rolled into the core,
7904    * rather than left in POSIX.xs.
7905    *
7906    * (DRS, Oct 23, 1997)
7907    */
7908
7909   /* sigset_t is atomic under VMS, so these routines are easy */
7910 /*{{{int my_sigemptyset(sigset_t *) */
7911 int my_sigemptyset(sigset_t *set) {
7912     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
7913     *set = 0; return 0;
7914 }
7915 /*}}}*/
7916
7917
7918 /*{{{int my_sigfillset(sigset_t *)*/
7919 int my_sigfillset(sigset_t *set) {
7920     int i;
7921     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
7922     for (i = 0; i < NSIG; i++) *set |= (1 << i);
7923     return 0;
7924 }
7925 /*}}}*/
7926
7927
7928 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
7929 int my_sigaddset(sigset_t *set, int sig) {
7930     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
7931     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
7932     *set |= (1 << (sig - 1));
7933     return 0;
7934 }
7935 /*}}}*/
7936
7937
7938 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
7939 int my_sigdelset(sigset_t *set, int sig) {
7940     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
7941     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
7942     *set &= ~(1 << (sig - 1));
7943     return 0;
7944 }
7945 /*}}}*/
7946
7947
7948 /*{{{int my_sigismember(sigset_t *set, int sig)*/
7949 int my_sigismember(sigset_t *set, int sig) {
7950     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
7951     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
7952     return *set & (1 << (sig - 1));
7953 }
7954 /*}}}*/
7955
7956
7957 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
7958 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
7959     sigset_t tempmask;
7960
7961     /* If set and oset are both null, then things are badly wrong. Bail out. */
7962     if ((oset == NULL) && (set == NULL)) {
7963       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
7964       return -1;
7965     }
7966
7967     /* If set's null, then we're just handling a fetch. */
7968     if (set == NULL) {
7969         tempmask = sigblock(0);
7970     }
7971     else {
7972       switch (how) {
7973       case SIG_SETMASK:
7974         tempmask = sigsetmask(*set);
7975         break;
7976       case SIG_BLOCK:
7977         tempmask = sigblock(*set);
7978         break;
7979       case SIG_UNBLOCK:
7980         tempmask = sigblock(0);
7981         sigsetmask(*oset & ~tempmask);
7982         break;
7983       default:
7984         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7985         return -1;
7986       }
7987     }
7988
7989     /* Did they pass us an oset? If so, stick our holding mask into it */
7990     if (oset)
7991       *oset = tempmask;
7992
7993     return 0;
7994 }
7995 /*}}}*/
7996 #endif  /* HOMEGROWN_POSIX_SIGNALS */
7997
7998
7999 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8000  * my_utime(), and flex_stat(), all of which operate on UTC unless
8001  * VMSISH_TIMES is true.
8002  */
8003 /* method used to handle UTC conversions:
8004  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8005  */
8006 static int gmtime_emulation_type;
8007 /* number of secs to add to UTC POSIX-style time to get local time */
8008 static long int utc_offset_secs;
8009
8010 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8011  * in vmsish.h.  #undef them here so we can call the CRTL routines
8012  * directly.
8013  */
8014 #undef gmtime
8015 #undef localtime
8016 #undef time
8017
8018
8019 /*
8020  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8021  * qualifier with the extern prefix pragma.  This provisional
8022  * hack circumvents this prefix pragma problem in previous
8023  * precompilers.
8024  */
8025 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8026 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8027 #    pragma __extern_prefix save
8028 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8029 #    define gmtime decc$__utctz_gmtime
8030 #    define localtime decc$__utctz_localtime
8031 #    define time decc$__utc_time
8032 #    pragma __extern_prefix restore
8033
8034      struct tm *gmtime(), *localtime();
8035
8036 #  endif
8037 #endif
8038
8039
8040 static time_t toutc_dst(time_t loc) {
8041   struct tm *rsltmp;
8042
8043   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8044   loc -= utc_offset_secs;
8045   if (rsltmp->tm_isdst) loc -= 3600;
8046   return loc;
8047 }
8048 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8049        ((gmtime_emulation_type || my_time(NULL)), \
8050        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8051        ((secs) - utc_offset_secs))))
8052
8053 static time_t toloc_dst(time_t utc) {
8054   struct tm *rsltmp;
8055
8056   utc += utc_offset_secs;
8057   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8058   if (rsltmp->tm_isdst) utc += 3600;
8059   return utc;
8060 }
8061 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8062        ((gmtime_emulation_type || my_time(NULL)), \
8063        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8064        ((secs) + utc_offset_secs))))
8065
8066 #ifndef RTL_USES_UTC
8067 /*
8068
8069     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8070         DST starts on 1st sun of april      at 02:00  std time
8071             ends on last sun of october     at 02:00  dst time
8072     see the UCX management command reference, SET CONFIG TIMEZONE
8073     for formatting info.
8074
8075     No, it's not as general as it should be, but then again, NOTHING
8076     will handle UK times in a sensible way.
8077 */
8078
8079
8080 /*
8081     parse the DST start/end info:
8082     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8083 */
8084
8085 static char *
8086 tz_parse_startend(char *s, struct tm *w, int *past)
8087 {
8088     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8089     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8090     time_t g;
8091
8092     if (!s)    return 0;
8093     if (!w) return 0;
8094     if (!past) return 0;
8095
8096     ly = 0;
8097     if (w->tm_year % 4        == 0) ly = 1;
8098     if (w->tm_year % 100      == 0) ly = 0;
8099     if (w->tm_year+1900 % 400 == 0) ly = 1;
8100     if (ly) dinm[1]++;
8101
8102     dozjd = isdigit(*s);
8103     if (*s == 'J' || *s == 'j' || dozjd) {
8104         if (!dozjd && !isdigit(*++s)) return 0;
8105         d = *s++ - '0';
8106         if (isdigit(*s)) {
8107             d = d*10 + *s++ - '0';
8108             if (isdigit(*s)) {
8109                 d = d*10 + *s++ - '0';
8110             }
8111         }
8112         if (d == 0) return 0;
8113         if (d > 366) return 0;
8114         d--;
8115         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8116         g = d * 86400;
8117         dozjd = 1;
8118     } else if (*s == 'M' || *s == 'm') {
8119         if (!isdigit(*++s)) return 0;
8120         m = *s++ - '0';
8121         if (isdigit(*s)) m = 10*m + *s++ - '0';
8122         if (*s != '.') return 0;
8123         if (!isdigit(*++s)) return 0;
8124         n = *s++ - '0';
8125         if (n < 1 || n > 5) return 0;
8126         if (*s != '.') return 0;
8127         if (!isdigit(*++s)) return 0;
8128         d = *s++ - '0';
8129         if (d > 6) return 0;
8130     }
8131
8132     if (*s == '/') {
8133         if (!isdigit(*++s)) return 0;
8134         hour = *s++ - '0';
8135         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8136         if (*s == ':') {
8137             if (!isdigit(*++s)) return 0;
8138             min = *s++ - '0';
8139             if (isdigit(*s)) min = 10*min + *s++ - '0';
8140             if (*s == ':') {
8141                 if (!isdigit(*++s)) return 0;
8142                 sec = *s++ - '0';
8143                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8144             }
8145         }
8146     } else {
8147         hour = 2;
8148         min = 0;
8149         sec = 0;
8150     }
8151
8152     if (dozjd) {
8153         if (w->tm_yday < d) goto before;
8154         if (w->tm_yday > d) goto after;
8155     } else {
8156         if (w->tm_mon+1 < m) goto before;
8157         if (w->tm_mon+1 > m) goto after;
8158
8159         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8160         k = d - j; /* mday of first d */
8161         if (k <= 0) k += 7;
8162         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8163         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8164         if (w->tm_mday < k) goto before;
8165         if (w->tm_mday > k) goto after;
8166     }
8167
8168     if (w->tm_hour < hour) goto before;
8169     if (w->tm_hour > hour) goto after;
8170     if (w->tm_min  < min)  goto before;
8171     if (w->tm_min  > min)  goto after;
8172     if (w->tm_sec  < sec)  goto before;
8173     goto after;
8174
8175 before:
8176     *past = 0;
8177     return s;
8178 after:
8179     *past = 1;
8180     return s;
8181 }
8182
8183
8184
8185
8186 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8187
8188 static char *
8189 tz_parse_offset(char *s, int *offset)
8190 {
8191     int hour = 0, min = 0, sec = 0;
8192     int neg = 0;
8193     if (!s) return 0;
8194     if (!offset) return 0;
8195
8196     if (*s == '-') {neg++; s++;}
8197     if (*s == '+') s++;
8198     if (!isdigit(*s)) return 0;
8199     hour = *s++ - '0';
8200     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8201     if (hour > 24) return 0;
8202     if (*s == ':') {
8203         if (!isdigit(*++s)) return 0;
8204         min = *s++ - '0';
8205         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8206         if (min > 59) return 0;
8207         if (*s == ':') {
8208             if (!isdigit(*++s)) return 0;
8209             sec = *s++ - '0';
8210             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8211             if (sec > 59) return 0;
8212         }
8213     }
8214
8215     *offset = (hour*60+min)*60 + sec;
8216     if (neg) *offset = -*offset;
8217     return s;
8218 }
8219
8220 /*
8221     input time is w, whatever type of time the CRTL localtime() uses.
8222     sets dst, the zone, and the gmtoff (seconds)
8223
8224     caches the value of TZ and UCX$TZ env variables; note that
8225     my_setenv looks for these and sets a flag if they're changed
8226     for efficiency.
8227
8228     We have to watch out for the "australian" case (dst starts in
8229     october, ends in april)...flagged by "reverse" and checked by
8230     scanning through the months of the previous year.
8231
8232 */
8233
8234 static int
8235 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8236 {
8237     time_t when;
8238     struct tm *w2;
8239     char *s,*s2;
8240     char *dstzone, *tz, *s_start, *s_end;
8241     int std_off, dst_off, isdst;
8242     int y, dststart, dstend;
8243     static char envtz[1025];  /* longer than any logical, symbol, ... */
8244     static char ucxtz[1025];
8245     static char reversed = 0;
8246
8247     if (!w) return 0;
8248
8249     if (tz_updated) {
8250         tz_updated = 0;
8251         reversed = -1;  /* flag need to check  */
8252         envtz[0] = ucxtz[0] = '\0';
8253         tz = my_getenv("TZ",0);
8254         if (tz) strcpy(envtz, tz);
8255         tz = my_getenv("UCX$TZ",0);
8256         if (tz) strcpy(ucxtz, tz);
8257         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
8258     }
8259     tz = envtz;
8260     if (!*tz) tz = ucxtz;
8261
8262     s = tz;
8263     while (isalpha(*s)) s++;
8264     s = tz_parse_offset(s, &std_off);
8265     if (!s) return 0;
8266     if (!*s) {                  /* no DST, hurray we're done! */
8267         isdst = 0;
8268         goto done;
8269     }
8270
8271     dstzone = s;
8272     while (isalpha(*s)) s++;
8273     s2 = tz_parse_offset(s, &dst_off);
8274     if (s2) {
8275         s = s2;
8276     } else {
8277         dst_off = std_off - 3600;
8278     }
8279
8280     if (!*s) {      /* default dst start/end?? */
8281         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
8282             s = strchr(ucxtz,',');
8283         }
8284         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
8285     }
8286     if (*s != ',') return 0;
8287
8288     when = *w;
8289     when = _toutc(when);      /* convert to utc */
8290     when = when - std_off;    /* convert to pseudolocal time*/
8291
8292     w2 = localtime(&when);
8293     y = w2->tm_year;
8294     s_start = s+1;
8295     s = tz_parse_startend(s_start,w2,&dststart);
8296     if (!s) return 0;
8297     if (*s != ',') return 0;
8298
8299     when = *w;
8300     when = _toutc(when);      /* convert to utc */
8301     when = when - dst_off;    /* convert to pseudolocal time*/
8302     w2 = localtime(&when);
8303     if (w2->tm_year != y) {   /* spans a year, just check one time */
8304         when += dst_off - std_off;
8305         w2 = localtime(&when);
8306     }
8307     s_end = s+1;
8308     s = tz_parse_startend(s_end,w2,&dstend);
8309     if (!s) return 0;
8310
8311     if (reversed == -1) {  /* need to check if start later than end */
8312         int j, ds, de;
8313
8314         when = *w;
8315         if (when < 2*365*86400) {
8316             when += 2*365*86400;
8317         } else {
8318             when -= 365*86400;
8319         }
8320         w2 =localtime(&when);
8321         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
8322
8323         for (j = 0; j < 12; j++) {
8324             w2 =localtime(&when);
8325             tz_parse_startend(s_start,w2,&ds);
8326             tz_parse_startend(s_end,w2,&de);
8327             if (ds != de) break;
8328             when += 30*86400;
8329         }
8330         reversed = 0;
8331         if (de && !ds) reversed = 1;
8332     }
8333
8334     isdst = dststart && !dstend;
8335     if (reversed) isdst = dststart  || !dstend;
8336
8337 done:
8338     if (dst)    *dst = isdst;
8339     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
8340     if (isdst)  tz = dstzone;
8341     if (zone) {
8342         while(isalpha(*tz))  *zone++ = *tz++;
8343         *zone = '\0';
8344     }
8345     return 1;
8346 }
8347
8348 #endif /* !RTL_USES_UTC */
8349
8350 /* my_time(), my_localtime(), my_gmtime()
8351  * By default traffic in UTC time values, using CRTL gmtime() or
8352  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
8353  * Note: We need to use these functions even when the CRTL has working
8354  * UTC support, since they also handle C<use vmsish qw(times);>
8355  *
8356  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
8357  * Modified by Charles Bailey <bailey@newman.upenn.edu>
8358  */
8359
8360 /*{{{time_t my_time(time_t *timep)*/
8361 time_t Perl_my_time(pTHX_ time_t *timep)
8362 {
8363   time_t when;
8364   struct tm *tm_p;
8365
8366   if (gmtime_emulation_type == 0) {
8367     int dstnow;
8368     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
8369                               /* results of calls to gmtime() and localtime() */
8370                               /* for same &base */
8371
8372     gmtime_emulation_type++;
8373     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
8374       char off[LNM$C_NAMLENGTH+1];;
8375
8376       gmtime_emulation_type++;
8377       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
8378         gmtime_emulation_type++;
8379         utc_offset_secs = 0;
8380         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
8381       }
8382       else { utc_offset_secs = atol(off); }
8383     }
8384     else { /* We've got a working gmtime() */
8385       struct tm gmt, local;
8386
8387       gmt = *tm_p;
8388       tm_p = localtime(&base);
8389       local = *tm_p;
8390       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
8391       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
8392       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
8393       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
8394     }
8395   }
8396
8397   when = time(NULL);
8398 # ifdef VMSISH_TIME
8399 # ifdef RTL_USES_UTC
8400   if (VMSISH_TIME) when = _toloc(when);
8401 # else
8402   if (!VMSISH_TIME) when = _toutc(when);
8403 # endif
8404 # endif
8405   if (timep != NULL) *timep = when;
8406   return when;
8407
8408 }  /* end of my_time() */
8409 /*}}}*/
8410
8411
8412 /*{{{struct tm *my_gmtime(const time_t *timep)*/
8413 struct tm *
8414 Perl_my_gmtime(pTHX_ const time_t *timep)
8415 {
8416   char *p;
8417   time_t when;
8418   struct tm *rsltmp;
8419
8420   if (timep == NULL) {
8421     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8422     return NULL;
8423   }
8424   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8425
8426   when = *timep;
8427 # ifdef VMSISH_TIME
8428   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
8429 #  endif
8430 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
8431   return gmtime(&when);
8432 # else
8433   /* CRTL localtime() wants local time as input, so does no tz correction */
8434   rsltmp = localtime(&when);
8435   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
8436   return rsltmp;
8437 #endif
8438 }  /* end of my_gmtime() */
8439 /*}}}*/
8440
8441
8442 /*{{{struct tm *my_localtime(const time_t *timep)*/
8443 struct tm *
8444 Perl_my_localtime(pTHX_ const time_t *timep)
8445 {
8446   time_t when, whenutc;
8447   struct tm *rsltmp;
8448   int dst, offset;
8449
8450   if (timep == NULL) {
8451     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8452     return NULL;
8453   }
8454   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8455   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
8456
8457   when = *timep;
8458 # ifdef RTL_USES_UTC
8459 # ifdef VMSISH_TIME
8460   if (VMSISH_TIME) when = _toutc(when);
8461 # endif
8462   /* CRTL localtime() wants UTC as input, does tz correction itself */
8463   return localtime(&when);
8464
8465 # else /* !RTL_USES_UTC */
8466   whenutc = when;
8467 # ifdef VMSISH_TIME
8468   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
8469   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
8470 # endif
8471   dst = -1;
8472 #ifndef RTL_USES_UTC
8473   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
8474       when = whenutc - offset;                   /* pseudolocal time*/
8475   }
8476 # endif
8477   /* CRTL localtime() wants local time as input, so does no tz correction */
8478   rsltmp = localtime(&when);
8479   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
8480   return rsltmp;
8481 # endif
8482
8483 } /*  end of my_localtime() */
8484 /*}}}*/
8485
8486 /* Reset definitions for later calls */
8487 #define gmtime(t)    my_gmtime(t)
8488 #define localtime(t) my_localtime(t)
8489 #define time(t)      my_time(t)
8490
8491
8492 /* my_utime - update modification time of a file
8493  * calling sequence is identical to POSIX utime(), but under
8494  * VMS only the modification time is changed; ODS-2 does not
8495  * maintain access times.  Restrictions differ from the POSIX
8496  * definition in that the time can be changed as long as the
8497  * caller has permission to execute the necessary IO$_MODIFY $QIO;
8498  * no separate checks are made to insure that the caller is the
8499  * owner of the file or has special privs enabled.
8500  * Code here is based on Joe Meadows' FILE utility.
8501  */
8502
8503 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
8504  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
8505  * in 100 ns intervals.
8506  */
8507 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
8508
8509 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
8510 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
8511 {
8512   register int i;
8513   int sts;
8514   long int bintime[2], len = 2, lowbit, unixtime,
8515            secscale = 10000000; /* seconds --> 100 ns intervals */
8516   unsigned long int chan, iosb[2], retsts;
8517   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
8518   struct FAB myfab = cc$rms_fab;
8519   struct NAM mynam = cc$rms_nam;
8520 #if defined (__DECC) && defined (__VAX)
8521   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
8522    * at least through VMS V6.1, which causes a type-conversion warning.
8523    */
8524 #  pragma message save
8525 #  pragma message disable cvtdiftypes
8526 #endif
8527   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
8528   struct fibdef myfib;
8529 #if defined (__DECC) && defined (__VAX)
8530   /* This should be right after the declaration of myatr, but due
8531    * to a bug in VAX DEC C, this takes effect a statement early.
8532    */
8533 #  pragma message restore
8534 #endif
8535   /* cast ok for read only parameter */
8536   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
8537                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
8538                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
8539
8540   if (file == NULL || *file == '\0') {
8541     set_errno(ENOENT);
8542     set_vaxc_errno(LIB$_INVARG);
8543     return -1;
8544   }
8545   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
8546
8547   if (utimes != NULL) {
8548     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
8549      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
8550      * Since time_t is unsigned long int, and lib$emul takes a signed long int
8551      * as input, we force the sign bit to be clear by shifting unixtime right
8552      * one bit, then multiplying by an extra factor of 2 in lib$emul().
8553      */
8554     lowbit = (utimes->modtime & 1) ? secscale : 0;
8555     unixtime = (long int) utimes->modtime;
8556 #   ifdef VMSISH_TIME
8557     /* If input was UTC; convert to local for sys svc */
8558     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
8559 #   endif
8560     unixtime >>= 1;  secscale <<= 1;
8561     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
8562     if (!(retsts & 1)) {
8563       set_errno(EVMSERR);
8564       set_vaxc_errno(retsts);
8565       return -1;
8566     }
8567     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
8568     if (!(retsts & 1)) {
8569       set_errno(EVMSERR);
8570       set_vaxc_errno(retsts);
8571       return -1;
8572     }
8573   }
8574   else {
8575     /* Just get the current time in VMS format directly */
8576     retsts = sys$gettim(bintime);
8577     if (!(retsts & 1)) {
8578       set_errno(EVMSERR);
8579       set_vaxc_errno(retsts);
8580       return -1;
8581     }
8582   }
8583
8584   myfab.fab$l_fna = vmsspec;
8585   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
8586   myfab.fab$l_nam = &mynam;
8587   mynam.nam$l_esa = esa;
8588   mynam.nam$b_ess = (unsigned char) sizeof esa;
8589   mynam.nam$l_rsa = rsa;
8590   mynam.nam$b_rss = (unsigned char) sizeof rsa;
8591   if (decc_efs_case_preserve)
8592       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
8593
8594   /* Look for the file to be affected, letting RMS parse the file
8595    * specification for us as well.  I have set errno using only
8596    * values documented in the utime() man page for VMS POSIX.
8597    */
8598   retsts = sys$parse(&myfab,0,0);
8599   if (!(retsts & 1)) {
8600     set_vaxc_errno(retsts);
8601     if      (retsts == RMS$_PRV) set_errno(EACCES);
8602     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
8603     else                         set_errno(EVMSERR);
8604     return -1;
8605   }
8606   retsts = sys$search(&myfab,0,0);
8607   if (!(retsts & 1)) {
8608     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
8609     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
8610     set_vaxc_errno(retsts);
8611     if      (retsts == RMS$_PRV) set_errno(EACCES);
8612     else if (retsts == RMS$_FNF) set_errno(ENOENT);
8613     else                         set_errno(EVMSERR);
8614     return -1;
8615   }
8616
8617   devdsc.dsc$w_length = mynam.nam$b_dev;
8618   /* cast ok for read only parameter */
8619   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
8620
8621   retsts = sys$assign(&devdsc,&chan,0,0);
8622   if (!(retsts & 1)) {
8623     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
8624     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
8625     set_vaxc_errno(retsts);
8626     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
8627     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
8628     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
8629     else                               set_errno(EVMSERR);
8630     return -1;
8631   }
8632
8633   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
8634   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
8635
8636   memset((void *) &myfib, 0, sizeof myfib);
8637 #if defined(__DECC) || defined(__DECCXX)
8638   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
8639   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
8640   /* This prevents the revision time of the file being reset to the current
8641    * time as a result of our IO$_MODIFY $QIO. */
8642   myfib.fib$l_acctl = FIB$M_NORECORD;
8643 #else
8644   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
8645   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
8646   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
8647 #endif
8648   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
8649   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
8650   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
8651   _ckvmssts(sys$dassgn(chan));
8652   if (retsts & 1) retsts = iosb[0];
8653   if (!(retsts & 1)) {
8654     set_vaxc_errno(retsts);
8655     if (retsts == SS$_NOPRIV) set_errno(EACCES);
8656     else                      set_errno(EVMSERR);
8657     return -1;
8658   }
8659
8660   return 0;
8661 }  /* end of my_utime() */
8662 /*}}}*/
8663
8664 /*
8665  * flex_stat, flex_lstat, flex_fstat
8666  * basic stat, but gets it right when asked to stat
8667  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
8668  */
8669
8670 #ifndef _USE_STD_STAT
8671 /* encode_dev packs a VMS device name string into an integer to allow
8672  * simple comparisons. This can be used, for example, to check whether two
8673  * files are located on the same device, by comparing their encoded device
8674  * names. Even a string comparison would not do, because stat() reuses the
8675  * device name buffer for each call; so without encode_dev, it would be
8676  * necessary to save the buffer and use strcmp (this would mean a number of
8677  * changes to the standard Perl code, to say nothing of what a Perl script
8678  * would have to do.
8679  *
8680  * The device lock id, if it exists, should be unique (unless perhaps compared
8681  * with lock ids transferred from other nodes). We have a lock id if the disk is
8682  * mounted cluster-wide, which is when we tend to get long (host-qualified)
8683  * device names. Thus we use the lock id in preference, and only if that isn't
8684  * available, do we try to pack the device name into an integer (flagged by
8685  * the sign bit (LOCKID_MASK) being set).
8686  *
8687  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
8688  * name and its encoded form, but it seems very unlikely that we will find
8689  * two files on different disks that share the same encoded device names,
8690  * and even more remote that they will share the same file id (if the test
8691  * is to check for the same file).
8692  *
8693  * A better method might be to use sys$device_scan on the first call, and to
8694  * search for the device, returning an index into the cached array.
8695  * The number returned would be more intelligable.
8696  * This is probably not worth it, and anyway would take quite a bit longer
8697  * on the first call.
8698  */
8699 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
8700 static mydev_t encode_dev (pTHX_ const char *dev)
8701 {
8702   int i;
8703   unsigned long int f;
8704   mydev_t enc;
8705   char c;
8706   const char *q;
8707
8708   if (!dev || !dev[0]) return 0;
8709
8710 #if LOCKID_MASK
8711   {
8712     struct dsc$descriptor_s dev_desc;
8713     unsigned long int status, lockid, item = DVI$_LOCKID;
8714
8715     /* For cluster-mounted disks, the disk lock identifier is unique, so we
8716        can try that first. */
8717     dev_desc.dsc$w_length =  strlen (dev);
8718     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
8719     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
8720     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
8721     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
8722     if (lockid) return (lockid & ~LOCKID_MASK);
8723   }
8724 #endif
8725
8726   /* Otherwise we try to encode the device name */
8727   enc = 0;
8728   f = 1;
8729   i = 0;
8730   for (q = dev + strlen(dev); q--; q >= dev) {
8731     if (isdigit (*q))
8732       c= (*q) - '0';
8733     else if (isalpha (toupper (*q)))
8734       c= toupper (*q) - 'A' + (char)10;
8735     else
8736       continue; /* Skip '$'s */
8737     i++;
8738     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
8739     if (i>1) f *= 36;
8740     enc += f * (unsigned long int) c;
8741   }
8742   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
8743
8744 }  /* end of encode_dev() */
8745 #endif
8746
8747 static char namecache[NAM$C_MAXRSS+1];
8748
8749 static int
8750 is_null_device(name)
8751     const char *name;
8752 {
8753   if (decc_bug_devnull != 0) {
8754     if (strcmp("/dev/null", name) == 0) /* temp hack */
8755       return 1;
8756   }
8757     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
8758        The underscore prefix, controller letter, and unit number are
8759        independently optional; for our purposes, the colon punctuation
8760        is not.  The colon can be trailed by optional directory and/or
8761        filename, but two consecutive colons indicates a nodename rather
8762        than a device.  [pr]  */
8763   if (*name == '_') ++name;
8764   if (tolower(*name++) != 'n') return 0;
8765   if (tolower(*name++) != 'l') return 0;
8766   if (tolower(*name) == 'a') ++name;
8767   if (*name == '0') ++name;
8768   return (*name++ == ':') && (*name != ':');
8769 }
8770
8771 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
8772 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
8773  * subset of the applicable information.
8774  */
8775 bool
8776 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
8777 {
8778   char fname_phdev[NAM$C_MAXRSS+1];
8779 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8780   /* Namecache not workable with symbolic links, as symbolic links do
8781    *  not have extensions and directories do in VMS mode.  So in order
8782    *  to test this, the did and ino_t must be used.
8783    *
8784    * Fix-me - Hide the information in the new stat structure
8785    *          Get rid of the namecache.
8786    */
8787   if (decc_posix_compliant_pathnames == 0)
8788 #endif
8789       if (statbufp == &PL_statcache)
8790           return cando_by_name(bit,effective,namecache);
8791   {
8792     char fname[NAM$C_MAXRSS+1];
8793     unsigned long int retsts;
8794     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
8795                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8796
8797     /* If the struct mystat is stale, we're OOL; stat() overwrites the
8798        device name on successive calls */
8799     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
8800     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
8801     namdsc.dsc$a_pointer = fname;
8802     namdsc.dsc$w_length = sizeof fname - 1;
8803
8804     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
8805                              &namdsc,&namdsc.dsc$w_length,0,0);
8806     if (retsts & 1) {
8807       fname[namdsc.dsc$w_length] = '\0';
8808 /*
8809  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
8810  * but if someone has redefined that logical, Perl gets very lost.  Since
8811  * we have the physical device name from the stat buffer, just paste it on.
8812  */
8813       strcpy( fname_phdev, statbufp->st_devnam );
8814       strcat( fname_phdev, strrchr(fname, ':') );
8815
8816       return cando_by_name(bit,effective,fname_phdev);
8817     }
8818     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
8819       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
8820       return FALSE;
8821     }
8822     _ckvmssts(retsts);
8823     return FALSE;  /* Should never get to here */
8824   }
8825 }  /* end of cando() */
8826 /*}}}*/
8827
8828
8829 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
8830 I32
8831 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
8832 {
8833   static char usrname[L_cuserid];
8834   static struct dsc$descriptor_s usrdsc =
8835          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
8836   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
8837   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
8838   unsigned short int retlen, trnlnm_iter_count;
8839   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8840   union prvdef curprv;
8841   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
8842          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
8843   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
8844          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
8845          {0,0,0,0}};
8846   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
8847          {0,0,0,0}};
8848   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8849
8850   if (!fname || !*fname) return FALSE;
8851   /* Make sure we expand logical names, since sys$check_access doesn't */
8852   if (!strpbrk(fname,"/]>:")) {
8853     strcpy(fileified,fname);
8854     trnlnm_iter_count = 0;
8855     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
8856         trnlnm_iter_count++;
8857         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
8858     }
8859     fname = fileified;
8860   }
8861   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
8862   retlen = namdsc.dsc$w_length = strlen(vmsname);
8863   namdsc.dsc$a_pointer = vmsname;
8864   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
8865       vmsname[retlen-1] == ':') {
8866     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
8867     namdsc.dsc$w_length = strlen(fileified);
8868     namdsc.dsc$a_pointer = fileified;
8869   }
8870
8871   switch (bit) {
8872     case S_IXUSR: case S_IXGRP: case S_IXOTH:
8873       access = ARM$M_EXECUTE; break;
8874     case S_IRUSR: case S_IRGRP: case S_IROTH:
8875       access = ARM$M_READ; break;
8876     case S_IWUSR: case S_IWGRP: case S_IWOTH:
8877       access = ARM$M_WRITE; break;
8878     case S_IDUSR: case S_IDGRP: case S_IDOTH:
8879       access = ARM$M_DELETE; break;
8880     default:
8881       return FALSE;
8882   }
8883
8884   /* Before we call $check_access, create a user profile with the current
8885    * process privs since otherwise it just uses the default privs from the
8886    * UAF and might give false positives or negatives.  This only works on
8887    * VMS versions v6.0 and later since that's when sys$create_user_profile
8888    * became available.
8889    */
8890
8891   /* get current process privs and username */
8892   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
8893   _ckvmssts(iosb[0]);
8894
8895 #if defined(__VMS_VER) && __VMS_VER >= 60000000
8896
8897   /* find out the space required for the profile */
8898   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
8899                                     &usrprodsc.dsc$w_length,0));
8900
8901   /* allocate space for the profile and get it filled in */
8902   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
8903   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
8904                                     &usrprodsc.dsc$w_length,0));
8905
8906   /* use the profile to check access to the file; free profile & analyze results */
8907   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
8908   Safefree(usrprodsc.dsc$a_pointer);
8909   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
8910
8911 #else
8912
8913   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
8914
8915 #endif
8916
8917   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
8918       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
8919       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
8920     set_vaxc_errno(retsts);
8921     if (retsts == SS$_NOPRIV) set_errno(EACCES);
8922     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
8923     else set_errno(ENOENT);
8924     return FALSE;
8925   }
8926   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
8927     return TRUE;
8928   }
8929   _ckvmssts(retsts);
8930
8931   return FALSE;  /* Should never get here */
8932
8933 }  /* end of cando_by_name() */
8934 /*}}}*/
8935
8936
8937 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
8938 int
8939 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
8940 {
8941   if (!fstat(fd,(stat_t *) statbufp)) {
8942     if (statbufp == (Stat_t *) &PL_statcache) {
8943     char *cptr;
8944
8945         /* Save name for cando by name in VMS format */
8946         cptr = getname(fd, namecache, 1);
8947
8948         /* This should not happen, but just in case */
8949         if (cptr == NULL)
8950            namecache[0] = '\0';
8951     }
8952     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
8953 #ifndef _USE_STD_STAT
8954     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
8955     statbufp->st_devnam[63] = 0;
8956     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
8957 #else
8958     /* todo:
8959      * The device is only encoded so that Perl_cando can use it to
8960      * look up ACLS.  So rmsexpand it to the 255 character version
8961      * and store it in ->st_devnam.  rmsexpand needs to be fixed
8962      * for long filenames and symbolic links first.  This also seems
8963      * to remove the need for a namecache that could be stale.
8964      */
8965 #endif
8966
8967 #   ifdef RTL_USES_UTC
8968 #   ifdef VMSISH_TIME
8969     if (VMSISH_TIME) {
8970       statbufp->st_mtime = _toloc(statbufp->st_mtime);
8971       statbufp->st_atime = _toloc(statbufp->st_atime);
8972       statbufp->st_ctime = _toloc(statbufp->st_ctime);
8973     }
8974 #   endif
8975 #   else
8976 #   ifdef VMSISH_TIME
8977     if (!VMSISH_TIME) { /* Return UTC instead of local time */
8978 #   else
8979     if (1) {
8980 #   endif
8981       statbufp->st_mtime = _toutc(statbufp->st_mtime);
8982       statbufp->st_atime = _toutc(statbufp->st_atime);
8983       statbufp->st_ctime = _toutc(statbufp->st_ctime);
8984     }
8985 #endif
8986     return 0;
8987   }
8988   return -1;
8989
8990 }  /* end of flex_fstat() */
8991 /*}}}*/
8992
8993 #if !defined(__VAX) && __CRTL_VER >= 80200000
8994 #ifdef lstat
8995 #undef lstat
8996 #endif
8997 #else
8998 #ifdef lstat
8999 #undef lstat
9000 #endif
9001 #define lstat(_x, _y) stat(_x, _y)
9002 #endif
9003
9004 static int
9005 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9006 {
9007     char fileified[NAM$C_MAXRSS+1];
9008     char temp_fspec[NAM$C_MAXRSS+300];
9009     int retval = -1;
9010     int saved_errno, saved_vaxc_errno;
9011
9012     if (!fspec) return retval;
9013     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9014     strcpy(temp_fspec, fspec);
9015     if (statbufp == (Stat_t *) &PL_statcache)
9016       do_tovmsspec(temp_fspec,namecache,0);
9017     if (decc_bug_devnull != 0) {
9018       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9019         memset(statbufp,0,sizeof *statbufp);
9020         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9021         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9022         statbufp->st_uid = 0x00010001;
9023         statbufp->st_gid = 0x0001;
9024         time((time_t *)&statbufp->st_mtime);
9025         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9026         return 0;
9027       }
9028     }
9029
9030     /* Try for a directory name first.  If fspec contains a filename without
9031      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9032      * and sea:[wine.dark]water. exist, we prefer the directory here.
9033      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9034      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9035      * the file with null type, specify this by calling flex_stat() with
9036      * a '.' at the end of fspec.
9037      *
9038      * If we are in Posix filespec mode, accept the filename as is.
9039      */
9040 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9041   if (decc_posix_compliant_pathnames == 0) {
9042 #endif
9043     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9044       if (lstat_flag == 0)
9045         retval = stat(fileified,(stat_t *) statbufp);
9046       else
9047         retval = lstat(fileified,(stat_t *) statbufp);
9048       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9049         strcpy(namecache,fileified);
9050     }
9051     if (retval) {
9052       if (lstat_flag == 0)
9053         retval = stat(temp_fspec,(stat_t *) statbufp);
9054       else
9055         retval = lstat(temp_fspec,(stat_t *) statbufp);
9056     }
9057 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9058   } else {
9059     if (lstat_flag == 0)
9060       retval = stat(temp_fspec,(stat_t *) statbufp);
9061     else
9062       retval = lstat(temp_fspec,(stat_t *) statbufp);
9063   }
9064 #endif
9065     if (!retval) {
9066       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9067 #ifndef _USE_STD_STAT
9068       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9069       statbufp->st_devnam[63] = 0;
9070       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9071 #else
9072     /* todo:
9073      * The device is only encoded so that Perl_cando can use it to
9074      * look up ACLS.  So rmsexpand it to the 255 character version
9075      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9076      * for long filenames and symbolic links first.  This also seems
9077      * to remove the need for a namecache that could be stale.
9078      */
9079 #endif
9080 #     ifdef RTL_USES_UTC
9081 #     ifdef VMSISH_TIME
9082       if (VMSISH_TIME) {
9083         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9084         statbufp->st_atime = _toloc(statbufp->st_atime);
9085         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9086       }
9087 #     endif
9088 #     else
9089 #     ifdef VMSISH_TIME
9090       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9091 #     else
9092       if (1) {
9093 #     endif
9094         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9095         statbufp->st_atime = _toutc(statbufp->st_atime);
9096         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9097       }
9098 #     endif
9099     }
9100     /* If we were successful, leave errno where we found it */
9101     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9102     return retval;
9103
9104 }  /* end of flex_stat_int() */
9105
9106
9107 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9108 int
9109 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9110 {
9111    return Perl_flex_stat_int(fspec, statbufp, 0);
9112 }
9113 /*}}}*/
9114
9115 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9116 int
9117 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9118 {
9119    return Perl_flex_stat_int(fspec, statbufp, 1);
9120 }
9121 /*}}}*/
9122
9123
9124 /*{{{char *my_getlogin()*/
9125 /* VMS cuserid == Unix getlogin, except calling sequence */
9126 char *
9127 my_getlogin(void)
9128 {
9129     static char user[L_cuserid];
9130     return cuserid(user);
9131 }
9132 /*}}}*/
9133
9134
9135 /*  rmscopy - copy a file using VMS RMS routines
9136  *
9137  *  Copies contents and attributes of spec_in to spec_out, except owner
9138  *  and protection information.  Name and type of spec_in are used as
9139  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9140  *  should try to propagate timestamps from the input file to the output file.
9141  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9142  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9143  *  propagated to the output file at creation iff the output file specification
9144  *  did not contain an explicit name or type, and the revision date is always
9145  *  updated at the end of the copy operation.  If it is greater than 0, then
9146  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9147  *  other than the revision date should be propagated, and bit 1 indicates
9148  *  that the revision date should be propagated.
9149  *
9150  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9151  *
9152  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9153  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9154  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9155  * as part of the Perl standard distribution under the terms of the
9156  * GNU General Public License or the Perl Artistic License.  Copies
9157  * of each may be found in the Perl standard distribution.
9158  */
9159 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9160 int
9161 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9162 {
9163     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9164          rsa[NAM$C_MAXRSS], ubf[32256];
9165     unsigned long int i, sts, sts2;
9166     struct FAB fab_in, fab_out;
9167     struct RAB rab_in, rab_out;
9168     struct NAM nam;
9169     struct XABDAT xabdat;
9170     struct XABFHC xabfhc;
9171     struct XABRDT xabrdt;
9172     struct XABSUM xabsum;
9173
9174     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9175         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9176       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9177       return 0;
9178     }
9179
9180     fab_in = cc$rms_fab;
9181     fab_in.fab$l_fna = vmsin;
9182     fab_in.fab$b_fns = strlen(vmsin);
9183     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9184     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9185     fab_in.fab$l_fop = FAB$M_SQO;
9186     fab_in.fab$l_nam =  &nam;
9187     fab_in.fab$l_xab = (void *) &xabdat;
9188
9189     nam = cc$rms_nam;
9190     nam.nam$l_rsa = rsa;
9191     nam.nam$b_rss = sizeof(rsa);
9192     nam.nam$l_esa = esa;
9193     nam.nam$b_ess = sizeof (esa);
9194     nam.nam$b_esl = nam.nam$b_rsl = 0;
9195 #ifdef NAM$M_NO_SHORT_UPCASE
9196     if (decc_efs_case_preserve)
9197         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9198 #endif
9199
9200     xabdat = cc$rms_xabdat;        /* To get creation date */
9201     xabdat.xab$l_nxt = (void *) &xabfhc;
9202
9203     xabfhc = cc$rms_xabfhc;        /* To get record length */
9204     xabfhc.xab$l_nxt = (void *) &xabsum;
9205
9206     xabsum = cc$rms_xabsum;        /* To get key and area information */
9207
9208     if (!((sts = sys$open(&fab_in)) & 1)) {
9209       set_vaxc_errno(sts);
9210       switch (sts) {
9211         case RMS$_FNF: case RMS$_DNF:
9212           set_errno(ENOENT); break;
9213         case RMS$_DIR:
9214           set_errno(ENOTDIR); break;
9215         case RMS$_DEV:
9216           set_errno(ENODEV); break;
9217         case RMS$_SYN:
9218           set_errno(EINVAL); break;
9219         case RMS$_PRV:
9220           set_errno(EACCES); break;
9221         default:
9222           set_errno(EVMSERR);
9223       }
9224       return 0;
9225     }
9226
9227     fab_out = fab_in;
9228     fab_out.fab$w_ifi = 0;
9229     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9230     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9231     fab_out.fab$l_fop = FAB$M_SQO;
9232     fab_out.fab$l_fna = vmsout;
9233     fab_out.fab$b_fns = strlen(vmsout);
9234     fab_out.fab$l_dna = nam.nam$l_name;
9235     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
9236
9237     if (preserve_dates == 0) {  /* Act like DCL COPY */
9238       nam.nam$b_nop |= NAM$M_SYNCHK;
9239       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
9240       if (!((sts = sys$parse(&fab_out)) & 1)) {
9241         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9242         set_vaxc_errno(sts);
9243         return 0;
9244       }
9245       fab_out.fab$l_xab = (void *) &xabdat;
9246       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
9247     }
9248     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
9249     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
9250       preserve_dates =0;      /* bitmask from this point forward   */
9251
9252     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
9253     if (!((sts = sys$create(&fab_out)) & 1)) {
9254       set_vaxc_errno(sts);
9255       switch (sts) {
9256         case RMS$_DNF:
9257           set_errno(ENOENT); break;
9258         case RMS$_DIR:
9259           set_errno(ENOTDIR); break;
9260         case RMS$_DEV:
9261           set_errno(ENODEV); break;
9262         case RMS$_SYN:
9263           set_errno(EINVAL); break;
9264         case RMS$_PRV:
9265           set_errno(EACCES); break;
9266         default:
9267           set_errno(EVMSERR);
9268       }
9269       return 0;
9270     }
9271     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
9272     if (preserve_dates & 2) {
9273       /* sys$close() will process xabrdt, not xabdat */
9274       xabrdt = cc$rms_xabrdt;
9275 #ifndef __GNUC__
9276       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
9277 #else
9278       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
9279        * is unsigned long[2], while DECC & VAXC use a struct */
9280       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
9281 #endif
9282       fab_out.fab$l_xab = (void *) &xabrdt;
9283     }
9284
9285     rab_in = cc$rms_rab;
9286     rab_in.rab$l_fab = &fab_in;
9287     rab_in.rab$l_rop = RAB$M_BIO;
9288     rab_in.rab$l_ubf = ubf;
9289     rab_in.rab$w_usz = sizeof ubf;
9290     if (!((sts = sys$connect(&rab_in)) & 1)) {
9291       sys$close(&fab_in); sys$close(&fab_out);
9292       set_errno(EVMSERR); set_vaxc_errno(sts);
9293       return 0;
9294     }
9295
9296     rab_out = cc$rms_rab;
9297     rab_out.rab$l_fab = &fab_out;
9298     rab_out.rab$l_rbf = ubf;
9299     if (!((sts = sys$connect(&rab_out)) & 1)) {
9300       sys$close(&fab_in); sys$close(&fab_out);
9301       set_errno(EVMSERR); set_vaxc_errno(sts);
9302       return 0;
9303     }
9304
9305     while ((sts = sys$read(&rab_in))) {  /* always true  */
9306       if (sts == RMS$_EOF) break;
9307       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
9308       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
9309         sys$close(&fab_in); sys$close(&fab_out);
9310         set_errno(EVMSERR); set_vaxc_errno(sts);
9311         return 0;
9312       }
9313     }
9314
9315     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
9316     sys$close(&fab_in);  sys$close(&fab_out);
9317     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
9318     if (!(sts & 1)) {
9319       set_errno(EVMSERR); set_vaxc_errno(sts);
9320       return 0;
9321     }
9322
9323     return 1;
9324
9325 }  /* end of rmscopy() */
9326 /*}}}*/
9327
9328
9329 /***  The following glue provides 'hooks' to make some of the routines
9330  * from this file available from Perl.  These routines are sufficiently
9331  * basic, and are required sufficiently early in the build process,
9332  * that's it's nice to have them available to miniperl as well as the
9333  * full Perl, so they're set up here instead of in an extension.  The
9334  * Perl code which handles importation of these names into a given
9335  * package lives in [.VMS]Filespec.pm in @INC.
9336  */
9337
9338 void
9339 rmsexpand_fromperl(pTHX_ CV *cv)
9340 {
9341   dXSARGS;
9342   char *fspec, *defspec = NULL, *rslt;
9343   STRLEN n_a;
9344
9345   if (!items || items > 2)
9346     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
9347   fspec = SvPV(ST(0),n_a);
9348   if (!fspec || !*fspec) XSRETURN_UNDEF;
9349   if (items == 2) defspec = SvPV(ST(1),n_a);
9350
9351   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
9352   ST(0) = sv_newmortal();
9353   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
9354   XSRETURN(1);
9355 }
9356
9357 void
9358 vmsify_fromperl(pTHX_ CV *cv)
9359 {
9360   dXSARGS;
9361   char *vmsified;
9362   STRLEN n_a;
9363
9364   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
9365   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
9366   ST(0) = sv_newmortal();
9367   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
9368   XSRETURN(1);
9369 }
9370
9371 void
9372 unixify_fromperl(pTHX_ CV *cv)
9373 {
9374   dXSARGS;
9375   char *unixified;
9376   STRLEN n_a;
9377
9378   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
9379   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
9380   ST(0) = sv_newmortal();
9381   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
9382   XSRETURN(1);
9383 }
9384
9385 void
9386 fileify_fromperl(pTHX_ CV *cv)
9387 {
9388   dXSARGS;
9389   char *fileified;
9390   STRLEN n_a;
9391
9392   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
9393   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
9394   ST(0) = sv_newmortal();
9395   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
9396   XSRETURN(1);
9397 }
9398
9399 void
9400 pathify_fromperl(pTHX_ CV *cv)
9401 {
9402   dXSARGS;
9403   char *pathified;
9404   STRLEN n_a;
9405
9406   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
9407   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
9408   ST(0) = sv_newmortal();
9409   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
9410   XSRETURN(1);
9411 }
9412
9413 void
9414 vmspath_fromperl(pTHX_ CV *cv)
9415 {
9416   dXSARGS;
9417   char *vmspath;
9418   STRLEN n_a;
9419
9420   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
9421   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
9422   ST(0) = sv_newmortal();
9423   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
9424   XSRETURN(1);
9425 }
9426
9427 void
9428 unixpath_fromperl(pTHX_ CV *cv)
9429 {
9430   dXSARGS;
9431   char *unixpath;
9432   STRLEN n_a;
9433
9434   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
9435   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
9436   ST(0) = sv_newmortal();
9437   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
9438   XSRETURN(1);
9439 }
9440
9441 void
9442 candelete_fromperl(pTHX_ CV *cv)
9443 {
9444   dXSARGS;
9445   char fspec[NAM$C_MAXRSS+1], *fsp;
9446   SV *mysv;
9447   IO *io;
9448   STRLEN n_a;
9449
9450   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
9451
9452   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9453   if (SvTYPE(mysv) == SVt_PVGV) {
9454     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
9455       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9456       ST(0) = &PL_sv_no;
9457       XSRETURN(1);
9458     }
9459     fsp = fspec;
9460   }
9461   else {
9462     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
9463       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9464       ST(0) = &PL_sv_no;
9465       XSRETURN(1);
9466     }
9467   }
9468
9469   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
9470   XSRETURN(1);
9471 }
9472
9473 void
9474 rmscopy_fromperl(pTHX_ CV *cv)
9475 {
9476   dXSARGS;
9477   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
9478   int date_flag;
9479   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9480                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9481   unsigned long int sts;
9482   SV *mysv;
9483   IO *io;
9484   STRLEN n_a;
9485
9486   if (items < 2 || items > 3)
9487     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
9488
9489   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9490   if (SvTYPE(mysv) == SVt_PVGV) {
9491     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
9492       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9493       ST(0) = &PL_sv_no;
9494       XSRETURN(1);
9495     }
9496     inp = inspec;
9497   }
9498   else {
9499     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
9500       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9501       ST(0) = &PL_sv_no;
9502       XSRETURN(1);
9503     }
9504   }
9505   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
9506   if (SvTYPE(mysv) == SVt_PVGV) {
9507     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
9508       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9509       ST(0) = &PL_sv_no;
9510       XSRETURN(1);
9511     }
9512     outp = outspec;
9513   }
9514   else {
9515     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
9516       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9517       ST(0) = &PL_sv_no;
9518       XSRETURN(1);
9519     }
9520   }
9521   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
9522
9523   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
9524   XSRETURN(1);
9525 }
9526
9527
9528 void
9529 mod2fname(pTHX_ CV *cv)
9530 {
9531   dXSARGS;
9532   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
9533        workbuff[NAM$C_MAXRSS*1 + 1];
9534   int total_namelen = 3, counter, num_entries;
9535   /* ODS-5 ups this, but we want to be consistent, so... */
9536   int max_name_len = 39;
9537   AV *in_array = (AV *)SvRV(ST(0));
9538
9539   num_entries = av_len(in_array);
9540
9541   /* All the names start with PL_. */
9542   strcpy(ultimate_name, "PL_");
9543
9544   /* Clean up our working buffer */
9545   Zero(work_name, sizeof(work_name), char);
9546
9547   /* Run through the entries and build up a working name */
9548   for(counter = 0; counter <= num_entries; counter++) {
9549     /* If it's not the first name then tack on a __ */
9550     if (counter) {
9551       strcat(work_name, "__");
9552     }
9553     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
9554                            PL_na));
9555   }
9556
9557   /* Check to see if we actually have to bother...*/
9558   if (strlen(work_name) + 3 <= max_name_len) {
9559     strcat(ultimate_name, work_name);
9560   } else {
9561     /* It's too darned big, so we need to go strip. We use the same */
9562     /* algorithm as xsubpp does. First, strip out doubled __ */
9563     char *source, *dest, last;
9564     dest = workbuff;
9565     last = 0;
9566     for (source = work_name; *source; source++) {
9567       if (last == *source && last == '_') {
9568         continue;
9569       }
9570       *dest++ = *source;
9571       last = *source;
9572     }
9573     /* Go put it back */
9574     strcpy(work_name, workbuff);
9575     /* Is it still too big? */
9576     if (strlen(work_name) + 3 > max_name_len) {
9577       /* Strip duplicate letters */
9578       last = 0;
9579       dest = workbuff;
9580       for (source = work_name; *source; source++) {
9581         if (last == toupper(*source)) {
9582         continue;
9583         }
9584         *dest++ = *source;
9585         last = toupper(*source);
9586       }
9587       strcpy(work_name, workbuff);
9588     }
9589
9590     /* Is it *still* too big? */
9591     if (strlen(work_name) + 3 > max_name_len) {
9592       /* Too bad, we truncate */
9593       work_name[max_name_len - 2] = 0;
9594     }
9595     strcat(ultimate_name, work_name);
9596   }
9597
9598   /* Okay, return it */
9599   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
9600   XSRETURN(1);
9601 }
9602
9603 void
9604 hushexit_fromperl(pTHX_ CV *cv)
9605 {
9606     dXSARGS;
9607
9608     if (items > 0) {
9609         VMSISH_HUSHED = SvTRUE(ST(0));
9610     }
9611     ST(0) = boolSV(VMSISH_HUSHED);
9612     XSRETURN(1);
9613 }
9614
9615 #ifdef HAS_SYMLINK
9616 static char *
9617 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
9618
9619 void
9620 vms_realpath_fromperl(pTHX_ CV *cv)
9621 {
9622   dXSARGS;
9623   char *fspec, *rslt_spec, *rslt;
9624   STRLEN n_a;
9625
9626   if (!items || items != 1)
9627     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
9628
9629   fspec = SvPV(ST(0),n_a);
9630   if (!fspec || !*fspec) XSRETURN_UNDEF;
9631
9632   Newx(rslt_spec, VMS_MAXRSS + 1, char);
9633   rslt = do_vms_realpath(fspec, rslt_spec);
9634   ST(0) = sv_newmortal();
9635   if (rslt != NULL)
9636     sv_usepvn(ST(0),rslt,strlen(rslt));
9637   else
9638     Safefree(rslt_spec);
9639   XSRETURN(1);
9640 }
9641 #endif
9642
9643 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9644 int do_vms_case_tolerant(void);
9645
9646 void
9647 vms_case_tolerant_fromperl(pTHX_ CV *cv)
9648 {
9649   dXSARGS;
9650   ST(0) = boolSV(do_vms_case_tolerant());
9651   XSRETURN(1);
9652 }
9653 #endif
9654
9655 void
9656 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
9657                           struct interp_intern *dst)
9658 {
9659     memcpy(dst,src,sizeof(struct interp_intern));
9660 }
9661
9662 void
9663 Perl_sys_intern_clear(pTHX)
9664 {
9665 }
9666
9667 void
9668 Perl_sys_intern_init(pTHX)
9669 {
9670     unsigned int ix = RAND_MAX;
9671     double x;
9672
9673     VMSISH_HUSHED = 0;
9674
9675     /* fix me later to track running under GNV */
9676     /* this allows some limited testing */
9677     MY_POSIX_EXIT = decc_filename_unix_report;
9678
9679     x = (float)ix;
9680     MY_INV_RAND_MAX = 1./x;
9681 }
9682
9683 void
9684 init_os_extras(void)
9685 {
9686   dTHX;
9687   char* file = __FILE__;
9688   char temp_buff[512];
9689   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
9690     no_translate_barewords = TRUE;
9691   } else {
9692     no_translate_barewords = FALSE;
9693   }
9694
9695   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
9696   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
9697   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
9698   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
9699   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
9700   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
9701   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
9702   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
9703   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
9704   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
9705   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
9706 #ifdef HAS_SYMLINK
9707   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
9708 #endif
9709 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9710   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
9711 #endif
9712
9713   store_pipelocs(aTHX);         /* will redo any earlier attempts */
9714
9715   return;
9716 }
9717
9718 #ifdef HAS_SYMLINK
9719
9720 #if __CRTL_VER == 80200000
9721 /* This missed getting in to the DECC SDK for 8.2 */
9722 char *realpath(const char *file_name, char * resolved_name, ...);
9723 #endif
9724
9725 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
9726 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
9727  * The perl fallback routine to provide realpath() is not as efficient
9728  * on OpenVMS.
9729  */
9730 static char *
9731 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9732 {
9733     return realpath(filespec, outbuf);
9734 }
9735
9736 /*}}}*/
9737 /* External entry points */
9738 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9739 { return do_vms_realpath(filespec, outbuf); }
9740 #else
9741 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9742 { return NULL; }
9743 #endif
9744
9745
9746 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9747 /* case_tolerant */
9748
9749 /*{{{int do_vms_case_tolerant(void)*/
9750 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
9751  * controlled by a process setting.
9752  */
9753 int do_vms_case_tolerant(void)
9754 {
9755     return vms_process_case_tolerant;
9756 }
9757 /*}}}*/
9758 /* External entry points */
9759 int Perl_vms_case_tolerant(void)
9760 { return do_vms_case_tolerant(); }
9761 #else
9762 int Perl_vms_case_tolerant(void)
9763 { return vms_process_case_tolerant; }
9764 #endif
9765
9766
9767  /* Start of DECC RTL Feature handling */
9768
9769 static int sys_trnlnm
9770    (const char * logname,
9771     char * value,
9772     int value_len)
9773 {
9774     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
9775     const unsigned long attr = LNM$M_CASE_BLIND;
9776     struct dsc$descriptor_s name_dsc;
9777     int status;
9778     unsigned short result;
9779     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
9780                                 {0, 0, 0, 0}};
9781
9782     name_dsc.dsc$w_length = strlen(logname);
9783     name_dsc.dsc$a_pointer = (char *)logname;
9784     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9785     name_dsc.dsc$b_class = DSC$K_CLASS_S;
9786
9787     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
9788
9789     if ($VMS_STATUS_SUCCESS(status)) {
9790
9791          /* Null terminate and return the string */
9792         /*--------------------------------------*/
9793         value[result] = 0;
9794     }
9795
9796     return status;
9797 }
9798
9799 static int sys_crelnm
9800    (const char * logname,
9801     const char * value)
9802 {
9803     int ret_val;
9804     const char * proc_table = "LNM$PROCESS_TABLE";
9805     struct dsc$descriptor_s proc_table_dsc;
9806     struct dsc$descriptor_s logname_dsc;
9807     struct itmlst_3 item_list[2];
9808
9809     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
9810     proc_table_dsc.dsc$w_length = strlen(proc_table);
9811     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9812     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
9813
9814     logname_dsc.dsc$a_pointer = (char *) logname;
9815     logname_dsc.dsc$w_length = strlen(logname);
9816     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9817     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
9818
9819     item_list[0].buflen = strlen(value);
9820     item_list[0].itmcode = LNM$_STRING;
9821     item_list[0].bufadr = (char *)value;
9822     item_list[0].retlen = NULL;
9823
9824     item_list[1].buflen = 0;
9825     item_list[1].itmcode = 0;
9826
9827     ret_val = sys$crelnm
9828                        (NULL,
9829                         (const struct dsc$descriptor_s *)&proc_table_dsc,
9830                         (const struct dsc$descriptor_s *)&logname_dsc,
9831                         NULL,
9832                         (const struct item_list_3 *) item_list);
9833
9834     return ret_val;
9835 }
9836
9837
9838 /* C RTL Feature settings */
9839
9840 static int set_features
9841    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
9842     int (* cli_routine)(void),  /* Not documented */
9843     void *image_info)           /* Not documented */
9844 {
9845     int status;
9846     int s;
9847     int dflt;
9848     char* str;
9849     char val_str[10];
9850     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
9851     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
9852     unsigned long case_perm;
9853     unsigned long case_image;
9854
9855     /* hacks to see if known bugs are still present for testing */
9856
9857     /* Readdir is returning filenames in VMS syntax always */
9858     decc_bug_readdir_efs1 = 1;
9859     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
9860     if ($VMS_STATUS_SUCCESS(status)) {
9861        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
9862          decc_bug_readdir_efs1 = 1;
9863        else
9864          decc_bug_readdir_efs1 = 0;
9865     }
9866
9867     /* PCP mode requires creating /dev/null special device file */
9868     decc_bug_devnull = 0;
9869     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
9870     if ($VMS_STATUS_SUCCESS(status)) {
9871        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
9872           decc_bug_devnull = 1;
9873     }
9874
9875     /* fgetname returning a VMS name in UNIX mode */
9876     decc_bug_fgetname = 1;
9877     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
9878     if ($VMS_STATUS_SUCCESS(status)) {
9879       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
9880         decc_bug_fgetname = 1;
9881       else
9882         decc_bug_fgetname = 0;
9883     }
9884
9885     /* UNIX directory names with no paths are broken in a lot of places */
9886     decc_dir_barename = 1;
9887     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
9888     if ($VMS_STATUS_SUCCESS(status)) {
9889       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
9890         decc_dir_barename = 1;
9891       else
9892         decc_dir_barename = 0;
9893     }
9894
9895 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9896     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
9897     if (s >= 0) {
9898         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
9899         if (decc_disable_to_vms_logname_translation < 0)
9900             decc_disable_to_vms_logname_translation = 0;
9901     }
9902
9903     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
9904     if (s >= 0) {
9905         decc_efs_case_preserve = decc$feature_get_value(s, 1);
9906         if (decc_efs_case_preserve < 0)
9907             decc_efs_case_preserve = 0;
9908     }
9909
9910     s = decc$feature_get_index("DECC$EFS_CHARSET");
9911     if (s >= 0) {
9912         decc_efs_charset = decc$feature_get_value(s, 1);
9913         if (decc_efs_charset < 0)
9914             decc_efs_charset = 0;
9915     }
9916
9917     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
9918     if (s >= 0) {
9919         decc_filename_unix_report = decc$feature_get_value(s, 1);
9920         if (decc_filename_unix_report > 0)
9921             decc_filename_unix_report = 1;
9922         else
9923             decc_filename_unix_report = 0;
9924     }
9925
9926     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
9927     if (s >= 0) {
9928         decc_filename_unix_only = decc$feature_get_value(s, 1);
9929         if (decc_filename_unix_only > 0) {
9930             decc_filename_unix_only = 1;
9931         }
9932         else {
9933             decc_filename_unix_only = 0;
9934         }
9935     }
9936
9937     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
9938     if (s >= 0) {
9939         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
9940         if (decc_filename_unix_no_version < 0)
9941             decc_filename_unix_no_version = 0;
9942     }
9943
9944     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
9945     if (s >= 0) {
9946         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
9947         if (decc_readdir_dropdotnotype < 0)
9948             decc_readdir_dropdotnotype = 0;
9949     }
9950
9951     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
9952     if ($VMS_STATUS_SUCCESS(status)) {
9953         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9954         if (s >= 0) {
9955             dflt = decc$feature_get_value(s, 4);
9956             if (dflt > 0) {
9957                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9958                 if (decc_disable_posix_root <= 0) {
9959                     decc$feature_set_value(s, 1, 1);
9960                     decc_disable_posix_root = 1;
9961                 }
9962             }
9963             else {
9964                 /* Traditionally Perl assumes this is off */
9965                 decc_disable_posix_root = 1;
9966                 decc$feature_set_value(s, 1, 1);
9967             }
9968         }
9969     }
9970
9971 #if __CRTL_VER >= 80200000
9972     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
9973     if (s >= 0) {
9974         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
9975         if (decc_posix_compliant_pathnames < 0)
9976             decc_posix_compliant_pathnames = 0;
9977         if (decc_posix_compliant_pathnames > 4)
9978             decc_posix_compliant_pathnames = 0;
9979     }
9980
9981 #endif
9982 #else
9983     status = sys_trnlnm
9984         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
9985     if ($VMS_STATUS_SUCCESS(status)) {
9986         val_str[0] = _toupper(val_str[0]);
9987         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
9988            decc_disable_to_vms_logname_translation = 1;
9989         }
9990     }
9991
9992 #ifndef __VAX
9993     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
9994     if ($VMS_STATUS_SUCCESS(status)) {
9995         val_str[0] = _toupper(val_str[0]);
9996         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
9997            decc_efs_case_preserve = 1;
9998         }
9999     }
10000 #endif
10001
10002     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
10003     if ($VMS_STATUS_SUCCESS(status)) {
10004         val_str[0] = _toupper(val_str[0]);
10005         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10006            decc_filename_unix_report = 1;
10007         }
10008     }
10009     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
10010     if ($VMS_STATUS_SUCCESS(status)) {
10011         val_str[0] = _toupper(val_str[0]);
10012         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10013            decc_filename_unix_only = 1;
10014            decc_filename_unix_report = 1;
10015         }
10016     }
10017     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
10018     if ($VMS_STATUS_SUCCESS(status)) {
10019         val_str[0] = _toupper(val_str[0]);
10020         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10021            decc_filename_unix_no_version = 1;
10022         }
10023     }
10024     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
10025     if ($VMS_STATUS_SUCCESS(status)) {
10026         val_str[0] = _toupper(val_str[0]);
10027         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10028            decc_readdir_dropdotnotype = 1;
10029         }
10030     }
10031 #endif
10032
10033 #ifndef __VAX
10034
10035      /* Report true case tolerance */
10036     /*----------------------------*/
10037     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
10038     if (!$VMS_STATUS_SUCCESS(status))
10039         case_perm = PPROP$K_CASE_BLIND;
10040     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
10041     if (!$VMS_STATUS_SUCCESS(status))
10042         case_image = PPROP$K_CASE_BLIND;
10043     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
10044         (case_image == PPROP$K_CASE_SENSITIVE))
10045         vms_process_case_tolerant = 0;
10046
10047 #endif
10048
10049
10050     /* CRTL can be initialized past this point, but not before. */
10051 /*    DECC$CRTL_INIT(); */
10052
10053     return SS$_NORMAL;
10054 }
10055
10056 #ifdef __DECC
10057 /* DECC dependent attributes */
10058 #if __DECC_VER < 60560002
10059 #define relative
10060 #define not_executable
10061 #else
10062 #define relative ,rel
10063 #define not_executable ,noexe
10064 #endif
10065 #pragma nostandard
10066 #pragma extern_model save
10067 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
10068 #endif
10069         const __align (LONGWORD) int spare[8] = {0};
10070 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
10071 /*                        NOWRT, LONG */
10072 #ifdef __DECC
10073 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
10074         nowrt,noshr relative not_executable
10075 #endif
10076 const long vms_cc_features = (const long)set_features;
10077
10078 /*
10079 ** Force a reference to LIB$INITIALIZE to ensure it
10080 ** exists in the image.
10081 */
10082 int lib$initialize(void);
10083 #ifdef __DECC
10084 #pragma extern_model strict_refdef
10085 #endif
10086     int lib_init_ref = (int) lib$initialize;
10087
10088 #ifdef __DECC
10089 #pragma extern_model restore
10090 #pragma standard
10091 #endif
10092
10093 /*  End of vms.c */