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