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 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  51 #include <utime.h>
  52 #endif
  53
  54 /* Set the maximum filespec size here as it is larger for EFS file
  55  * specifications.
  56  * Not fully implemented at this time because the larger size
  57  * will likely impact the stack local storage requirements of
  58  * threaded code, and probably cause hard to diagnose failures.
  59  * To implement the larger sizes, all places where filename
  60  * storage is put on the stack need to be changed to use
  61  * New()/SafeFree() instead.
  62  */
  63 #ifndef __VAX
  64 #ifndef VMS_MAXRSS
  65 #ifdef NAML$C_MAXRSS
  66 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  67 #ifndef VMS_LONGNAME_SUPPORT
  68 #define VMS_LONGNAME_SUPPORT 1
  69 #endif /* VMS_LONGNAME_SUPPORT */
  70 #endif /* NAML$C_MAXRSS */
  71 #endif /* VMS_MAXRSS */
  72 #endif
  73
  74 /* temporary hack until support is complete */
  75 #ifdef VMS_LONGNAME_SUPPORT
  76 #undef VMS_LONGNAME_SUPPORT
  77 #undef VMS_MAXRSS
  78 #endif
  79 /* end of temporary hack until support is complete */
  80
  81 #ifndef VMS_MAXRSS
  82 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  83 #endif
  84
  85 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  86 int   decc$feature_get_index(const char *name);
  87 char* decc$feature_get_name(int index);
  88 int   decc$feature_get_value(int index, int mode);
  89 int   decc$feature_set_value(int index, int mode, int value);
  90 #else
  91 #include <unixlib.h>
  92 #endif
  93
  94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  95
  96 static int set_feature_default(const char *name, int value)
  97 {
  98     int status;
  99     int index;
 100
 101     index = decc$feature_get_index(name);
 102
 103     status = decc$feature_set_value(index, 1, value);
 104     if (index == -1 || (status == -1)) {
 105       return -1;
 106     }
 107
 108     status = decc$feature_get_value(index, 1);
 109     if (status != value) {
 110       return -1;
 111     }
 112
 113 return 0;
 114 }
 115 #endif
 116
 117 /* Older versions of ssdef.h don't have these */
 118 #ifndef SS$_INVFILFOROP
 119 #  define SS$_INVFILFOROP 3930
 120 #endif
 121 #ifndef SS$_NOSUCHOBJECT
 122 #  define SS$_NOSUCHOBJECT 2696
 123 #endif
 124
 125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 126 #define PERLIO_NOT_STDIO 0
 127
 128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 129  * code below needs to get to the underlying CRTL routines. */
 130 #define DONT_MASK_RTL_CALLS
 131 #include "EXTERN.h"
 132 #include "perl.h"
 133 #include "XSUB.h"
 134 /* Anticipating future expansion in lexical warnings . . . */
 135 #ifndef WARN_INTERNAL
 136 #  define WARN_INTERNAL WARN_MISC
 137 #endif
 138
 139 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 140 #  define RTL_USES_UTC 1
 141 #endif
 142
 143
 144 /* gcc's header files don't #define direct access macros
 145  * corresponding to VAXC's variant structs */
 146 #ifdef __GNUC__
 147 #  define uic$v_format uic$r_uic_form.uic$v_format
 148 #  define uic$v_group uic$r_uic_form.uic$v_group
 149 #  define uic$v_member uic$r_uic_form.uic$v_member
 150 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 151 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 152 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 153 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 154 #endif
 155
 156 #if defined(NEED_AN_H_ERRNO)
 157 dEXT int h_errno;
 158 #endif
 159
 160 #ifdef __DECC
 161 #pragma message disable pragma
 162 #pragma member_alignment save
 163 #pragma nomember_alignment longword
 164 #pragma message save
 165 #pragma message disable misalgndmem
 166 #endif
 167 struct itmlst_3 {
 168   unsigned short int buflen;
 169   unsigned short int itmcode;
 170   void *bufadr;
 171   unsigned short int *retlen;
 172 };
 173 #ifdef __DECC
 174 #pragma message restore
 175 #pragma member_alignment restore
 176 #endif
 177
 178 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 179 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 180 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 181 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 182 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 183 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 184 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 185 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 186 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 187 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 188 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 189
 190 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 191 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 192 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 193 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 194
 195 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 196 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 197
 198 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 199  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 200  * the Perl facility.
 201  */
 202 #define PERL_LNM_MAX_ITER 10
 203
 204   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 205 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 206 #define MAX_DCL_SYMBOL          (8192)
 207 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 208 #else
 209 #define MAX_DCL_SYMBOL          (1024)
 210 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 211 #endif
 212
 213 static char *__mystrtolower(char *str)
 214 {
 215   if (str) for (; *str; ++str) *str= tolower(*str);
 216   return str;
 217 }
 218
 219 static struct dsc$descriptor_s fildevdsc =
 220   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 221 static struct dsc$descriptor_s crtlenvdsc =
 222   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 223 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 224 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 225 static struct dsc$descriptor_s **env_tables = defenv;
 226 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 227
 228 /* True if we shouldn't treat barewords as logicals during directory */
 229 /* munching */
 230 static int no_translate_barewords;
 231
 232 #ifndef RTL_USES_UTC
 233 static int tz_updated = 1;
 234 #endif
 235
 236 /* DECC Features that may need to affect how Perl interprets
 237  * displays filename information
 238  */
 239 static int decc_disable_to_vms_logname_translation = 1;
 240 static int decc_disable_posix_root = 1;
 241 int decc_efs_case_preserve = 0;
 242 static int decc_efs_charset = 0;
 243 static int decc_filename_unix_no_version = 0;
 244 static int decc_filename_unix_only = 0;
 245 int decc_filename_unix_report = 0;
 246 int decc_posix_compliant_pathnames = 0;
 247 int decc_readdir_dropdotnotype = 0;
 248 static int vms_process_case_tolerant = 1;
 249
 250 /* bug workarounds if needed */
 251 int decc_bug_readdir_efs1 = 0;
 252 int decc_bug_devnull = 0;
 253 int decc_bug_fgetname = 0;
 254 int decc_dir_barename = 0;
 255
 256 /* Is this a UNIX file specification?
 257  *   No longer a simple check with EFS file specs
 258  *   For now, not a full check, but need to
 259  *   handle POSIX ^UP^ specifications
 260  *   Fixing to handle ^/ cases would require
 261  *   changes to many other conversion routines.
 262  */
 263
 264 static is_unix_filespec(const char *path)
 265 {
 266 int ret_val;
 267 const char * pch1;
 268
 269     ret_val = 0;
 270     if (strncmp(path,"\"^UP^",5) != 0) {
 271         pch1 = strchr(path, '/');
 272         if (pch1 != NULL)
 273             ret_val = 1;
 274         else {
 275
 276             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 277             if (decc_filename_unix_report || decc_filename_unix_only) {
 278             if (strcmp(path,".") == 0)
 279                 ret_val = 1;
 280             }
 281         }
 282     }
 283     return ret_val;
 284 }
 285
 286
 287 /* my_maxidx
 288  * Routine to retrieve the maximum equivalence index for an input
 289  * logical name.  Some calls to this routine have no knowledge if
 290  * the variable is a logical or not.  So on error we return a max
 291  * index of zero.
 292  */
 293 /*{{{int my_maxidx(const char *lnm) */
 294 static int
 295 my_maxidx(const char *lnm)
 296 {
 297     int status;
 298     int midx;
 299     int attr = LNM$M_CASE_BLIND;
 300     struct dsc$descriptor lnmdsc;
 301     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 302                                 {0, 0, 0, 0}};
 303
 304     lnmdsc.dsc$w_length = strlen(lnm);
 305     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 306     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 307     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 308
 309     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 310     if ((status & 1) == 0)
 311        midx = 0;
 312
 313     return (midx);
 314 }
 315 /*}}}*/
 316
 317 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 318 int
 319 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 320   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 321 {
 322     const char *cp1;
 323     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 324     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 325     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 326     int midx;
 327     unsigned char acmode;
 328     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 329                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 330     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 331                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 332                                  {0, 0, 0, 0}};
 333     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 334 #if defined(PERL_IMPLICIT_CONTEXT)
 335     pTHX = NULL;
 336     if (PL_curinterp) {
 337       aTHX = PERL_GET_INTERP;
 338     } else {
 339       aTHX = NULL;
 340     }
 341 #endif
 342
 343     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 344       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 345     }
 346     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 347       *cp2 = _toupper(*cp1);
 348       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 349         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 350         return 0;
 351       }
 352     }
 353     lnmdsc.dsc$w_length = cp1 - lnm;
 354     lnmdsc.dsc$a_pointer = uplnm;
 355     uplnm[lnmdsc.dsc$w_length] = '\0';
 356     secure = flags & PERL__TRNENV_SECURE;
 357     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 358     if (!tabvec || !*tabvec) tabvec = env_tables;
 359
 360     for (curtab = 0; tabvec[curtab]; curtab++) {
 361       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 362         if (!ivenv && !secure) {
 363           char *eq, *end;
 364           int i;
 365           if (!environ) {
 366             ivenv = 1;
 367             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 368             continue;
 369           }
 370           retsts = SS$_NOLOGNAM;
 371           for (i = 0; environ[i]; i++) {
 372             if ((eq = strchr(environ[i],'=')) &&
 373                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 374                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 375               eq++;
 376               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 377               if (!eqvlen) continue;
 378               retsts = SS$_NORMAL;
 379               break;
 380             }
 381           }
 382           if (retsts != SS$_NOLOGNAM) break;
 383         }
 384       }
 385       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 386                !str$case_blind_compare(&tmpdsc,&clisym)) {
 387         if (!ivsym && !secure) {
 388           unsigned short int deflen = LNM$C_NAMLENGTH;
 389           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 390           /* dynamic dsc to accomodate possible long value */
 391           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 392           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 393           if (retsts & 1) {
 394             if (eqvlen > MAX_DCL_SYMBOL) {
 395               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 396               eqvlen = MAX_DCL_SYMBOL;
 397               /* Special hack--we might be called before the interpreter's */
 398               /* fully initialized, in which case either thr or PL_curcop */
 399               /* might be bogus. We have to check, since ckWARN needs them */
 400               /* both to be valid if running threaded */
 401                 if (ckWARN(WARN_MISC)) {
 402                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 403                 }
 404             }
 405             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 406           }
 407           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 408           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 409           if (retsts == LIB$_NOSUCHSYM) continue;
 410           break;
 411         }
 412       }
 413       else if (!ivlnm) {
 414         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 415           midx = my_maxidx(lnm);
 416           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 417             lnmlst[1].bufadr = cp2;
 418             eqvlen = 0;
 419             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 420             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 421             if (retsts == SS$_NOLOGNAM) break;
 422             /* PPFs have a prefix */
 423             if (
 424 #if INTSIZE == 4
 425                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 426 #endif
 427                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 428                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 429                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 430                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 431                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 432               memmove(eqv,eqv+4,eqvlen-4);
 433               eqvlen -= 4;
 434             }
 435             cp2 += eqvlen;
 436             *cp2 = '\0';
 437           }
 438           if ((retsts == SS$_IVLOGNAM) ||
 439               (retsts == SS$_NOLOGNAM)) { continue; }
 440         }
 441         else {
 442           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 443           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 444           if (retsts == SS$_NOLOGNAM) continue;
 445           eqv[eqvlen] = '\0';
 446         }
 447         eqvlen = strlen(eqv);
 448         break;
 449       }
 450     }
 451     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 452     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 453              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 454              retsts == SS$_NOLOGNAM) {
 455       set_errno(EINVAL);  set_vaxc_errno(retsts);
 456     }
 457     else _ckvmssts(retsts);
 458     return 0;
 459 }  /* end of vmstrnenv */
 460 /*}}}*/
 461
 462 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 463 /* Define as a function so we can access statics. */
 464 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 465 {
 466   return vmstrnenv(lnm,eqv,idx,fildev,
 467 #ifdef SECURE_INTERNAL_GETENV
 468                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 469 #else
 470                    0
 471 #endif
 472                                                                               );
 473 }
 474 /*}}}*/
 475
 476 /* my_getenv
 477  * Note: Uses Perl temp to store result so char * can be returned to
 478  * caller; this pointer will be invalidated at next Perl statement
 479  * transition.
 480  * We define this as a function rather than a macro in terms of my_getenv_len()
 481  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 482  * allocate SVs).
 483  */
 484 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 485 char *
 486 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 487 {
 488     const char *cp1;
 489     static char *__my_getenv_eqv = NULL;
 490     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 491     unsigned long int idx = 0;
 492     int trnsuccess, success, secure, saverr, savvmserr;
 493     int midx, flags;
 494     SV *tmpsv;
 495
 496     midx = my_maxidx(lnm) + 1;
 497
 498     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 499       /* Set up a temporary buffer for the return value; Perl will
 500        * clean it up at the next statement transition */
 501       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 502       if (!tmpsv) return NULL;
 503       eqv = SvPVX(tmpsv);
 504     }
 505     else {
 506       /* Assume no interpreter ==> single thread */
 507       if (__my_getenv_eqv != NULL) {
 508         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 509       }
 510       else {
 511         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 512       }
 513       eqv = __my_getenv_eqv;
 514     }
 515
 516     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 517     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 518       int len;
 519       getcwd(eqv,LNM$C_NAMLENGTH);
 520
 521       len = strlen(eqv);
 522
 523       /* Get rid of "000000/ in rooted filespecs */
 524       if (len > 7) {
 525         char * zeros;
 526         zeros = strstr(eqv, "/000000/");
 527         if (zeros != NULL) {
 528           int mlen;
 529           mlen = len - (zeros - eqv) - 7;
 530           memmove(zeros, &zeros[7], mlen);
 531           len = len - 7;
 532           eqv[len] = '\0';
 533         }
 534       }
 535       return eqv;
 536     }
 537     else {
 538       /* Impose security constraints only if tainting */
 539       if (sys) {
 540         /* Impose security constraints only if tainting */
 541         secure = PL_curinterp ? PL_tainting : will_taint;
 542         saverr = errno;  savvmserr = vaxc$errno;
 543       }
 544       else {
 545         secure = 0;
 546       }
 547
 548       flags =
 549 #ifdef SECURE_INTERNAL_GETENV
 550               secure ? PERL__TRNENV_SECURE : 0
 551 #else
 552               0
 553 #endif
 554       ;
 555
 556       /* For the getenv interface we combine all the equivalence names
 557        * of a search list logical into one value to acquire a maximum
 558        * value length of 255*128 (assuming %ENV is using logicals).
 559        */
 560       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 561
 562       /* If the name contains a semicolon-delimited index, parse it
 563        * off and make sure we only retrieve the equivalence name for
 564        * that index.  */
 565       if ((cp2 = strchr(lnm,';')) != NULL) {
 566         strcpy(uplnm,lnm);
 567         uplnm[cp2-lnm] = '\0';
 568         idx = strtoul(cp2+1,NULL,0);
 569         lnm = uplnm;
 570         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 571       }
 572
 573       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 574
 575       /* Discard NOLOGNAM on internal calls since we're often looking
 576        * for an optional name, and this "error" often shows up as the
 577        * (bogus) exit status for a die() call later on.  */
 578       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 579       return success ? eqv : Nullch;
 580     }
 581
 582 }  /* end of my_getenv() */
 583 /*}}}*/
 584
 585
 586 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 587 char *
 588 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 589 {
 590     const char *cp1;
 591     char *buf, *cp2;
 592     unsigned long idx = 0;
 593     int midx, flags;
 594     static char *__my_getenv_len_eqv = NULL;
 595     int secure, saverr, savvmserr;
 596     SV *tmpsv;
 597
 598     midx = my_maxidx(lnm) + 1;
 599
 600     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 601       /* Set up a temporary buffer for the return value; Perl will
 602        * clean it up at the next statement transition */
 603       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 604       if (!tmpsv) return NULL;
 605       buf = SvPVX(tmpsv);
 606     }
 607     else {
 608       /* Assume no interpreter ==> single thread */
 609       if (__my_getenv_len_eqv != NULL) {
 610         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 611       }
 612       else {
 613         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 614       }
 615       buf = __my_getenv_len_eqv;
 616     }
 617
 618     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 619     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 620     char * zeros;
 621
 622       getcwd(buf,LNM$C_NAMLENGTH);
 623       *len = strlen(buf);
 624
 625       /* Get rid of "000000/ in rooted filespecs */
 626       if (*len > 7) {
 627       zeros = strstr(buf, "/000000/");
 628       if (zeros != NULL) {
 629         int mlen;
 630         mlen = *len - (zeros - buf) - 7;
 631         memmove(zeros, &zeros[7], mlen);
 632         *len = *len - 7;
 633         buf[*len] = '\0';
 634         }
 635       }
 636       return buf;
 637     }
 638     else {
 639       if (sys) {
 640         /* Impose security constraints only if tainting */
 641         secure = PL_curinterp ? PL_tainting : will_taint;
 642         saverr = errno;  savvmserr = vaxc$errno;
 643       }
 644       else {
 645         secure = 0;
 646       }
 647
 648       flags =
 649 #ifdef SECURE_INTERNAL_GETENV
 650               secure ? PERL__TRNENV_SECURE : 0
 651 #else
 652               0
 653 #endif
 654       ;
 655
 656       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 657
 658       if ((cp2 = strchr(lnm,';')) != NULL) {
 659         strcpy(buf,lnm);
 660         buf[cp2-lnm] = '\0';
 661         idx = strtoul(cp2+1,NULL,0);
 662         lnm = buf;
 663         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 664       }
 665
 666       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 667
 668       /* Get rid of "000000/ in rooted filespecs */
 669       if (*len > 7) {
 670       char * zeros;
 671         zeros = strstr(buf, "/000000/");
 672         if (zeros != NULL) {
 673           int mlen;
 674           mlen = *len - (zeros - buf) - 7;
 675           memmove(zeros, &zeros[7], mlen);
 676           *len = *len - 7;
 677           buf[*len] = '\0';
 678         }
 679       }
 680
 681       /* Discard NOLOGNAM on internal calls since we're often looking
 682        * for an optional name, and this "error" often shows up as the
 683        * (bogus) exit status for a die() call later on.  */
 684       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 685       return *len ? buf : Nullch;
 686     }
 687
 688 }  /* end of my_getenv_len() */
 689 /*}}}*/
 690
 691 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 692
 693 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 694
 695 /*{{{ void prime_env_iter() */
 696 void
 697 prime_env_iter(void)
 698 /* Fill the %ENV associative array with all logical names we can
 699  * find, in preparation for iterating over it.
 700  */
 701 {
 702   static int primed = 0;
 703   HV *seenhv = NULL, *envhv;
 704   SV *sv = NULL;
 705   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 706   unsigned short int chan;
 707 #ifndef CLI$M_TRUSTED
 708 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 709 #endif
 710   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 711   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 712   long int i;
 713   bool have_sym = FALSE, have_lnm = FALSE;
 714   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 715   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 716   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 717   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 718   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 719 #if defined(PERL_IMPLICIT_CONTEXT)
 720   pTHX;
 721 #endif
 722 #if defined(USE_ITHREADS)
 723   static perl_mutex primenv_mutex;
 724   MUTEX_INIT(&primenv_mutex);
 725 #endif
 726
 727 #if defined(PERL_IMPLICIT_CONTEXT)
 728     /* We jump through these hoops because we can be called at */
 729     /* platform-specific initialization time, which is before anything is */
 730     /* set up--we can't even do a plain dTHX since that relies on the */
 731     /* interpreter structure to be initialized */
 732     if (PL_curinterp) {
 733       aTHX = PERL_GET_INTERP;
 734     } else {
 735       aTHX = NULL;
 736     }
 737 #endif
 738
 739   if (primed || !PL_envgv) return;
 740   MUTEX_LOCK(&primenv_mutex);
 741   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 742   envhv = GvHVn(PL_envgv);
 743   /* Perform a dummy fetch as an lval to insure that the hash table is
 744    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 745   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 746
 747   for (i = 0; env_tables[i]; i++) {
 748      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 749          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 750      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 751   }
 752   if (have_sym || have_lnm) {
 753     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 754     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 755     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 756     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 757   }
 758
 759   for (i--; i >= 0; i--) {
 760     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 761       char *start;
 762       int j;
 763       for (j = 0; environ[j]; j++) {
 764         if (!(start = strchr(environ[j],'='))) {
 765           if (ckWARN(WARN_INTERNAL))
 766             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 767         }
 768         else {
 769           start++;
 770           sv = newSVpv(start,0);
 771           SvTAINTED_on(sv);
 772           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 773         }
 774       }
 775       continue;
 776     }
 777     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 778              !str$case_blind_compare(&tmpdsc,&clisym)) {
 779       strcpy(cmd,"Show Symbol/Global *");
 780       cmddsc.dsc$w_length = 20;
 781       if (env_tables[i]->dsc$w_length == 12 &&
 782           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 783           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 784       flags = defflags | CLI$M_NOLOGNAM;
 785     }
 786     else {
 787       strcpy(cmd,"Show Logical *");
 788       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 789         strcat(cmd," /Table=");
 790         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 791         cmddsc.dsc$w_length = strlen(cmd);
 792       }
 793       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 794       flags = defflags | CLI$M_NOCLISYM;
 795     }
 796
 797     /* Create a new subprocess to execute each command, to exclude the
 798      * remote possibility that someone could subvert a mbx or file used
 799      * to write multiple commands to a single subprocess.
 800      */
 801     do {
 802       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 803                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 804       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 805       defflags &= ~CLI$M_TRUSTED;
 806     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 807     _ckvmssts(retsts);
 808     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 809     if (seenhv) SvREFCNT_dec(seenhv);
 810     seenhv = newHV();
 811     while (1) {
 812       char *cp1, *cp2, *key;
 813       unsigned long int sts, iosb[2], retlen, keylen;
 814       register U32 hash;
 815
 816       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 817       if (sts & 1) sts = iosb[0] & 0xffff;
 818       if (sts == SS$_ENDOFFILE) {
 819         int wakect = 0;
 820         while (substs == 0) { sys$hiber(); wakect++;}
 821         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 822         _ckvmssts(substs);
 823         break;
 824       }
 825       _ckvmssts(sts);
 826       retlen = iosb[0] >> 16;
 827       if (!retlen) continue;  /* blank line */
 828       buf[retlen] = '\0';
 829       if (iosb[1] != subpid) {
 830         if (iosb[1]) {
 831           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 832         }
 833         continue;
 834       }
 835       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 836         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 837
 838       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 839       if (*cp1 == '(' || /* Logical name table name */
 840           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 841       if (*cp1 == '"') cp1++;
 842       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 843       key = cp1;  keylen = cp2 - cp1;
 844       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 845       while (*cp2 && *cp2 != '=') cp2++;
 846       while (*cp2 && *cp2 == '=') cp2++;
 847       while (*cp2 && *cp2 == ' ') cp2++;
 848       if (*cp2 == '"') {  /* String translation; may embed "" */
 849         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 850         cp2++;  cp1--; /* Skip "" surrounding translation */
 851       }
 852       else {  /* Numeric translation */
 853         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 854         cp1--;  /* stop on last non-space char */
 855       }
 856       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 857         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 858         continue;
 859       }
 860       PERL_HASH(hash,key,keylen);
 861
 862       if (cp1 == cp2 && *cp2 == '.') {
 863         /* A single dot usually means an unprintable character, such as a null
 864          * to indicate a zero-length value.  Get the actual value to make sure.
 865          */
 866         char lnm[LNM$C_NAMLENGTH+1];
 867         char eqv[MAX_DCL_SYMBOL+1];
 868         strncpy(lnm, key, keylen);
 869         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 870         sv = newSVpvn(eqv, strlen(eqv));
 871       }
 872       else {
 873         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 874       }
 875
 876       SvTAINTED_on(sv);
 877       hv_store(envhv,key,keylen,sv,hash);
 878       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 879     }
 880     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 881       /* get the PPFs for this process, not the subprocess */
 882       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 883       char eqv[LNM$C_NAMLENGTH+1];
 884       int trnlen, i;
 885       for (i = 0; ppfs[i]; i++) {
 886         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 887         sv = newSVpv(eqv,trnlen);
 888         SvTAINTED_on(sv);
 889         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 890       }
 891     }
 892   }
 893   primed = 1;
 894   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 895   if (buf) Safefree(buf);
 896   if (seenhv) SvREFCNT_dec(seenhv);
 897   MUTEX_UNLOCK(&primenv_mutex);
 898   return;
 899
 900 }  /* end of prime_env_iter */
 901 /*}}}*/
 902
 903
 904 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 905 /* Define or delete an element in the same "environment" as
 906  * vmstrnenv().  If an element is to be deleted, it's removed from
 907  * the first place it's found.  If it's to be set, it's set in the
 908  * place designated by the first element of the table vector.
 909  * Like setenv() returns 0 for success, non-zero on error.
 910  */
 911 int
 912 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 913 {
 914     const char *cp1;
 915     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 916     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 917     int nseg = 0, j;
 918     unsigned long int retsts, usermode = PSL$C_USER;
 919     struct itmlst_3 *ile, *ilist;
 920     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 921                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 922                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 923     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 924     $DESCRIPTOR(local,"_LOCAL");
 925
 926     if (!lnm) {
 927         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 928         return SS$_IVLOGNAM;
 929     }
 930
 931     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 932       *cp2 = _toupper(*cp1);
 933       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 934         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 935         return SS$_IVLOGNAM;
 936       }
 937     }
 938     lnmdsc.dsc$w_length = cp1 - lnm;
 939     if (!tabvec || !*tabvec) tabvec = env_tables;
 940
 941     if (!eqv) {  /* we're deleting n element */
 942       for (curtab = 0; tabvec[curtab]; curtab++) {
 943         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 944         int i;
 945           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 946             if ((cp1 = strchr(environ[i],'=')) &&
 947                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 948                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 949 #ifdef HAS_SETENV
 950               return setenv(lnm,"",1) ? vaxc$errno : 0;
 951             }
 952           }
 953           ivenv = 1; retsts = SS$_NOLOGNAM;
 954 #else
 955               if (ckWARN(WARN_INTERNAL))
 956                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 957               ivenv = 1; retsts = SS$_NOSUCHPGM;
 958               break;
 959             }
 960           }
 961 #endif
 962         }
 963         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 964                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 965           unsigned int symtype;
 966           if (tabvec[curtab]->dsc$w_length == 12 &&
 967               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 968               !str$case_blind_compare(&tmpdsc,&local))
 969             symtype = LIB$K_CLI_LOCAL_SYM;
 970           else symtype = LIB$K_CLI_GLOBAL_SYM;
 971           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 972           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 973           if (retsts == LIB$_NOSUCHSYM) continue;
 974           break;
 975         }
 976         else if (!ivlnm) {
 977           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 978           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 979           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 980           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 981           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 982         }
 983       }
 984     }
 985     else {  /* we're defining a value */
 986       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 987 #ifdef HAS_SETENV
 988         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 989 #else
 990         if (ckWARN(WARN_INTERNAL))
 991           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 992         retsts = SS$_NOSUCHPGM;
 993 #endif
 994       }
 995       else {
 996         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 997         eqvdsc.dsc$w_length  = strlen(eqv);
 998         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 999             !str$case_blind_compare(&tmpdsc,&clisym)) {
1000           unsigned int symtype;
1001           if (tabvec[0]->dsc$w_length == 12 &&
1002               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1003                !str$case_blind_compare(&tmpdsc,&local))
1004             symtype = LIB$K_CLI_LOCAL_SYM;
1005           else symtype = LIB$K_CLI_GLOBAL_SYM;
1006           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1007         }
1008         else {
1009           if (!*eqv) eqvdsc.dsc$w_length = 1;
1010           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1011
1012             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1013             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1014               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1015                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1016               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1017               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1018             }
1019
1020             Newx(ilist,nseg+1,struct itmlst_3);
1021             ile = ilist;
1022             if (!ile) {
1023               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1024               return SS$_INSFMEM;
1025             }
1026             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1027
1028             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1029               ile->itmcode = LNM$_STRING;
1030               ile->bufadr = c;
1031               if ((j+1) == nseg) {
1032                 ile->buflen = strlen(c);
1033                 /* in case we are truncating one that's too long */
1034                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1035               }
1036               else {
1037                 ile->buflen = LNM$C_NAMLENGTH;
1038               }
1039             }
1040
1041             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1042             Safefree (ilist);
1043           }
1044           else {
1045             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1046           }
1047         }
1048       }
1049     }
1050     if (!(retsts & 1)) {
1051       switch (retsts) {
1052         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1053         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1054           set_errno(EVMSERR); break;
1055         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1056         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1057           set_errno(EINVAL); break;
1058         case SS$_NOPRIV:
1059           set_errno(EACCES);
1060         default:
1061           _ckvmssts(retsts);
1062           set_errno(EVMSERR);
1063        }
1064        set_vaxc_errno(retsts);
1065        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1066     }
1067     else {
1068       /* We reset error values on success because Perl does an hv_fetch()
1069        * before each hv_store(), and if the thing we're setting didn't
1070        * previously exist, we've got a leftover error message.  (Of course,
1071        * this fails in the face of
1072        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1073        * in that the error reported in $! isn't spurious,
1074        * but it's right more often than not.)
1075        */
1076       set_errno(0); set_vaxc_errno(retsts);
1077       return 0;
1078     }
1079
1080 }  /* end of vmssetenv() */
1081 /*}}}*/
1082
1083 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1084 /* This has to be a function since there's a prototype for it in proto.h */
1085 void
1086 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1087 {
1088     if (lnm && *lnm) {
1089       int len = strlen(lnm);
1090       if  (len == 7) {
1091         char uplnm[8];
1092         int i;
1093         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1094         if (!strcmp(uplnm,"DEFAULT")) {
1095           if (eqv && *eqv) my_chdir(eqv);
1096           return;
1097         }
1098     }
1099 #ifndef RTL_USES_UTC
1100     if (len == 6 || len == 2) {
1101       char uplnm[7];
1102       int i;
1103       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1104       uplnm[len] = '\0';
1105       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1106       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1107     }
1108 #endif
1109   }
1110   (void) vmssetenv(lnm,eqv,NULL);
1111 }
1112 /*}}}*/
1113
1114 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1115 /*  vmssetuserlnm
1116  *  sets a user-mode logical in the process logical name table
1117  *  used for redirection of sys$error
1118  */
1119 void
1120 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1121 {
1122     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1123     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1124     unsigned long int iss, attr = LNM$M_CONFINE;
1125     unsigned char acmode = PSL$C_USER;
1126     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1127                                  {0, 0, 0, 0}};
1128     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1129     d_name.dsc$w_length = strlen(name);
1130
1131     lnmlst[0].buflen = strlen(eqv);
1132     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1133
1134     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1135     if (!(iss&1)) lib$signal(iss);
1136 }
1137 /*}}}*/
1138
1139
1140 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1141 /* my_crypt - VMS password hashing
1142  * my_crypt() provides an interface compatible with the Unix crypt()
1143  * C library function, and uses sys$hash_password() to perform VMS
1144  * password hashing.  The quadword hashed password value is returned
1145  * as a NUL-terminated 8 character string.  my_crypt() does not change
1146  * the case of its string arguments; in order to match the behavior
1147  * of LOGINOUT et al., alphabetic characters in both arguments must
1148  *  be upcased by the caller.
1149  *
1150  * - fix me to call ACM services when available
1151  */
1152 char *
1153 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1154 {
1155 #   ifndef UAI$C_PREFERRED_ALGORITHM
1156 #     define UAI$C_PREFERRED_ALGORITHM 127
1157 #   endif
1158     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1159     unsigned short int salt = 0;
1160     unsigned long int sts;
1161     struct const_dsc {
1162         unsigned short int dsc$w_length;
1163         unsigned char      dsc$b_type;
1164         unsigned char      dsc$b_class;
1165         const char *       dsc$a_pointer;
1166     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1167        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1168     struct itmlst_3 uailst[3] = {
1169         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1170         { sizeof salt, UAI$_SALT,    &salt, 0},
1171         { 0,           0,            NULL,  NULL}};
1172     static char hash[9];
1173
1174     usrdsc.dsc$w_length = strlen(usrname);
1175     usrdsc.dsc$a_pointer = usrname;
1176     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1177       switch (sts) {
1178         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1179           set_errno(EACCES);
1180           break;
1181         case RMS$_RNF:
1182           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1183           break;
1184         default:
1185           set_errno(EVMSERR);
1186       }
1187       set_vaxc_errno(sts);
1188       if (sts != RMS$_RNF) return NULL;
1189     }
1190
1191     txtdsc.dsc$w_length = strlen(textpasswd);
1192     txtdsc.dsc$a_pointer = textpasswd;
1193     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1194       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1195     }
1196
1197     return (char *) hash;
1198
1199 }  /* end of my_crypt() */
1200 /*}}}*/
1201
1202
1203 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1204 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1205 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1206
1207 /* fixup barenames that are directories for internal use.
1208  * There have been problems with the consistent handling of UNIX
1209  * style directory names when routines are presented with a name that
1210  * has no directory delimitors at all.  So this routine will eventually
1211  * fix the issue.
1212  */
1213 static char * fixup_bare_dirnames(const char * name)
1214 {
1215   if (decc_disable_to_vms_logname_translation) {
1216 /* fix me */
1217   }
1218   return NULL;
1219 }
1220
1221 /* mp_do_kill_file
1222  * A little hack to get around a bug in some implemenation of remove()
1223  * that do not know how to delete a directory
1224  *
1225  * Delete any file to which user has control access, regardless of whether
1226  * delete access is explicitly allowed.
1227  * Limitations: User must have write access to parent directory.
1228  *              Does not block signals or ASTs; if interrupted in midstream
1229  *              may leave file with an altered ACL.
1230  * HANDLE WITH CARE!
1231  */
1232 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1233 static int
1234 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1235 {
1236     char *vmsname, *rspec;
1237     char *remove_name;
1238     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1239     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1240     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1241     struct myacedef {
1242       unsigned char myace$b_length;
1243       unsigned char myace$b_type;
1244       unsigned short int myace$w_flags;
1245       unsigned long int myace$l_access;
1246       unsigned long int myace$l_ident;
1247     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1248                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1249       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1250      struct itmlst_3
1251        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1252                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1253        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1254        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1255        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1256        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1257
1258     /* Expand the input spec using RMS, since the CRTL remove() and
1259      * system services won't do this by themselves, so we may miss
1260      * a file "hiding" behind a logical name or search list. */
1261     Newx(vmsname, NAM$C_MAXRSS+1, char);
1262     if (do_tovmsspec(name,vmsname,0) == NULL) {
1263       Safefree(vmsname);
1264       return -1;
1265     }
1266
1267     if (decc_posix_compliant_pathnames) {
1268       /* In POSIX mode, we prefer to remove the UNIX name */
1269       rspec = vmsname;
1270       remove_name = (char *)name;
1271     }
1272     else {
1273       Newx(rspec, NAM$C_MAXRSS+1, char);
1274       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1275         Safefree(rspec);
1276         Safefree(vmsname);
1277         return -1;
1278       }
1279       Safefree(vmsname);
1280       remove_name = rspec;
1281     }
1282
1283 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1284     if (dirflag != 0) {
1285         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1286           Newx(remove_name, NAM$C_MAXRSS+1, char);
1287           do_pathify_dirspec(name, remove_name, 0);
1288           if (!rmdir(remove_name)) {
1289
1290             Safefree(remove_name);
1291             Safefree(rspec);
1292             return 0;   /* Can we just get rid of it? */
1293           }
1294         }
1295         else {
1296           if (!rmdir(remove_name)) {
1297             Safefree(rspec);
1298             return 0;   /* Can we just get rid of it? */
1299           }
1300         }
1301     }
1302     else
1303 #endif
1304       if (!remove(remove_name)) {
1305         Safefree(rspec);
1306         return 0;   /* Can we just get rid of it? */
1307       }
1308
1309     /* If not, can changing protections help? */
1310     if (vaxc$errno != RMS$_PRV) {
1311       Safefree(rspec);
1312       return -1;
1313     }
1314
1315     /* No, so we get our own UIC to use as a rights identifier,
1316      * and the insert an ACE at the head of the ACL which allows us
1317      * to delete the file.
1318      */
1319     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1320     fildsc.dsc$w_length = strlen(rspec);
1321     fildsc.dsc$a_pointer = rspec;
1322     cxt = 0;
1323     newace.myace$l_ident = oldace.myace$l_ident;
1324     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1325       switch (aclsts) {
1326         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1327           set_errno(ENOENT); break;
1328         case RMS$_DIR:
1329           set_errno(ENOTDIR); break;
1330         case RMS$_DEV:
1331           set_errno(ENODEV); break;
1332         case RMS$_SYN: case SS$_INVFILFOROP:
1333           set_errno(EINVAL); break;
1334         case RMS$_PRV:
1335           set_errno(EACCES); break;
1336         default:
1337           _ckvmssts(aclsts);
1338       }
1339       set_vaxc_errno(aclsts);
1340       Safefree(rspec);
1341       return -1;
1342     }
1343     /* Grab any existing ACEs with this identifier in case we fail */
1344     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1345     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1346                     || fndsts == SS$_NOMOREACE ) {
1347       /* Add the new ACE . . . */
1348       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1349         goto yourroom;
1350
1351 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1352       if (dirflag != 0)
1353         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1354           Newx(remove_name, NAM$C_MAXRSS+1, char);
1355           do_pathify_dirspec(name, remove_name, 0);
1356           rmsts = rmdir(remove_name);
1357           Safefree(remove_name);
1358         }
1359         else {
1360         rmsts = rmdir(remove_name);
1361         }
1362       else
1363 #endif
1364         rmsts = remove(remove_name);
1365       if (rmsts) {
1366         /* We blew it - dir with files in it, no write priv for
1367          * parent directory, etc.  Put things back the way they were. */
1368         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1369           goto yourroom;
1370         if (fndsts & 1) {
1371           addlst[0].bufadr = &oldace;
1372           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1373             goto yourroom;
1374         }
1375       }
1376     }
1377
1378     yourroom:
1379     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1380     /* We just deleted it, so of course it's not there.  Some versions of
1381      * VMS seem to return success on the unlock operation anyhow (after all
1382      * the unlock is successful), but others don't.
1383      */
1384     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1385     if (aclsts & 1) aclsts = fndsts;
1386     if (!(aclsts & 1)) {
1387       set_errno(EVMSERR);
1388       set_vaxc_errno(aclsts);
1389       Safefree(rspec);
1390       return -1;
1391     }
1392
1393     Safefree(rspec);
1394     return rmsts;
1395
1396 }  /* end of kill_file() */
1397 /*}}}*/
1398
1399
1400 /*{{{int do_rmdir(char *name)*/
1401 int
1402 Perl_do_rmdir(pTHX_ const char *name)
1403 {
1404     char dirfile[NAM$C_MAXRSS+1];
1405     int retval;
1406     Stat_t st;
1407
1408     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1409     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1410     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1411     return retval;
1412
1413 }  /* end of do_rmdir */
1414 /*}}}*/
1415
1416 /* kill_file
1417  * Delete any file to which user has control access, regardless of whether
1418  * delete access is explicitly allowed.
1419  * Limitations: User must have write access to parent directory.
1420  *              Does not block signals or ASTs; if interrupted in midstream
1421  *              may leave file with an altered ACL.
1422  * HANDLE WITH CARE!
1423  */
1424 /*{{{int kill_file(char *name)*/
1425 int
1426 Perl_kill_file(pTHX_ const char *name)
1427 {
1428     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1429     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1430     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1431     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1432     struct myacedef {
1433       unsigned char myace$b_length;
1434       unsigned char myace$b_type;
1435       unsigned short int myace$w_flags;
1436       unsigned long int myace$l_access;
1437       unsigned long int myace$l_ident;
1438     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1439                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1440       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1441      struct itmlst_3
1442        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1443                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1444        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1445        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1446        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1447        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1448
1449     /* Expand the input spec using RMS, since the CRTL remove() and
1450      * system services won't do this by themselves, so we may miss
1451      * a file "hiding" behind a logical name or search list. */
1452     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1453     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1454     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1455     /* If not, can changing protections help? */
1456     if (vaxc$errno != RMS$_PRV) return -1;
1457
1458     /* No, so we get our own UIC to use as a rights identifier,
1459      * and the insert an ACE at the head of the ACL which allows us
1460      * to delete the file.
1461      */
1462     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1463     fildsc.dsc$w_length = strlen(rspec);
1464     fildsc.dsc$a_pointer = rspec;
1465     cxt = 0;
1466     newace.myace$l_ident = oldace.myace$l_ident;
1467     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1468       switch (aclsts) {
1469         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1470           set_errno(ENOENT); break;
1471         case RMS$_DIR:
1472           set_errno(ENOTDIR); break;
1473         case RMS$_DEV:
1474           set_errno(ENODEV); break;
1475         case RMS$_SYN: case SS$_INVFILFOROP:
1476           set_errno(EINVAL); break;
1477         case RMS$_PRV:
1478           set_errno(EACCES); break;
1479         default:
1480           _ckvmssts(aclsts);
1481       }
1482       set_vaxc_errno(aclsts);
1483       return -1;
1484     }
1485     /* Grab any existing ACEs with this identifier in case we fail */
1486     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1487     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1488                     || fndsts == SS$_NOMOREACE ) {
1489       /* Add the new ACE . . . */
1490       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1491         goto yourroom;
1492       if ((rmsts = remove(name))) {
1493         /* We blew it - dir with files in it, no write priv for
1494          * parent directory, etc.  Put things back the way they were. */
1495         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1496           goto yourroom;
1497         if (fndsts & 1) {
1498           addlst[0].bufadr = &oldace;
1499           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1500             goto yourroom;
1501         }
1502       }
1503     }
1504
1505     yourroom:
1506     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1507     /* We just deleted it, so of course it's not there.  Some versions of
1508      * VMS seem to return success on the unlock operation anyhow (after all
1509      * the unlock is successful), but others don't.
1510      */
1511     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1512     if (aclsts & 1) aclsts = fndsts;
1513     if (!(aclsts & 1)) {
1514       set_errno(EVMSERR);
1515       set_vaxc_errno(aclsts);
1516       return -1;
1517     }
1518
1519     return rmsts;
1520
1521 }  /* end of kill_file() */
1522 /*}}}*/
1523
1524
1525 /*{{{int my_mkdir(char *,Mode_t)*/
1526 int
1527 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1528 {
1529   STRLEN dirlen = strlen(dir);
1530
1531   /* zero length string sometimes gives ACCVIO */
1532   if (dirlen == 0) return -1;
1533
1534   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1535    * null file name/type.  However, it's commonplace under Unix,
1536    * so we'll allow it for a gain in portability.
1537    */
1538   if (dir[dirlen-1] == '/') {
1539     char *newdir = savepvn(dir,dirlen-1);
1540     int ret = mkdir(newdir,mode);
1541     Safefree(newdir);
1542     return ret;
1543   }
1544   else return mkdir(dir,mode);
1545 }  /* end of my_mkdir */
1546 /*}}}*/
1547
1548 /*{{{int my_chdir(char *)*/
1549 int
1550 Perl_my_chdir(pTHX_ const char *dir)
1551 {
1552   STRLEN dirlen = strlen(dir);
1553
1554   /* zero length string sometimes gives ACCVIO */
1555   if (dirlen == 0) return -1;
1556   const char *dir1;
1557
1558   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1559    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1560    * so that existing scripts do not need to be changed.
1561    */
1562   dir1 = dir;
1563   while ((dirlen > 0) && (*dir1 == ' ')) {
1564     dir1++;
1565     dirlen--;
1566   }
1567
1568   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1569    * that implies
1570    * null file name/type.  However, it's commonplace under Unix,
1571    * so we'll allow it for a gain in portability.
1572    *
1573    * - Preview- '/' will be valid soon on VMS
1574    */
1575   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1576     char *newdir = savepvn(dir,dirlen-1);
1577     int ret = chdir(newdir);
1578     Safefree(newdir);
1579     return ret;
1580   }
1581   else return chdir(dir);
1582 }  /* end of my_chdir */
1583 /*}}}*/
1584
1585
1586 /*{{{FILE *my_tmpfile()*/
1587 FILE *
1588 my_tmpfile(void)
1589 {
1590   FILE *fp;
1591   char *cp;
1592
1593   if ((fp = tmpfile())) return fp;
1594
1595   Newx(cp,L_tmpnam+24,char);
1596   if (decc_filename_unix_only == 0)
1597     strcpy(cp,"Sys$Scratch:");
1598   else
1599     strcpy(cp,"/tmp/");
1600   tmpnam(cp+strlen(cp));
1601   strcat(cp,".Perltmp");
1602   fp = fopen(cp,"w+","fop=dlt");
1603   Safefree(cp);
1604   return fp;
1605 }
1606 /*}}}*/
1607
1608
1609 #ifndef HOMEGROWN_POSIX_SIGNALS
1610 /*
1611  * The C RTL's sigaction fails to check for invalid signal numbers so we
1612  * help it out a bit.  The docs are correct, but the actual routine doesn't
1613  * do what the docs say it will.
1614  */
1615 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1616 int
1617 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1618                    struct sigaction* oact)
1619 {
1620   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1621         SETERRNO(EINVAL, SS$_INVARG);
1622         return -1;
1623   }
1624   return sigaction(sig, act, oact);
1625 }
1626 /*}}}*/
1627 #endif
1628
1629 #ifdef KILL_BY_SIGPRC
1630 #include <errnodef.h>
1631
1632 /* We implement our own kill() using the undocumented system service
1633    sys$sigprc for one of two reasons:
1634
1635    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1636    target process to do a sys$exit, which usually can't be handled
1637    gracefully...certainly not by Perl and the %SIG{} mechanism.
1638
1639    2.) If the kill() in the CRTL can't be called from a signal
1640    handler without disappearing into the ether, i.e., the signal
1641    it purportedly sends is never trapped. Still true as of VMS 7.3.
1642
1643    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1644    in the target process rather than calling sys$exit.
1645
1646    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1647    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1648    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1649    with condition codes C$_SIG0+nsig*8, catching the exception on the
1650    target process and resignaling with appropriate arguments.
1651
1652    But we don't have that VMS 7.0+ exception handler, so if you
1653    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1654
1655    Also note that SIGTERM is listed in the docs as being "unimplemented",
1656    yet always seems to be signaled with a VMS condition code of 4 (and
1657    correctly handled for that code).  So we hardwire it in.
1658
1659    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1660    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1661    than signalling with an unrecognized (and unhandled by CRTL) code.
1662 */
1663
1664 #define _MY_SIG_MAX 17
1665
1666 unsigned int
1667 Perl_sig_to_vmscondition(int sig)
1668 {
1669     static unsigned int sig_code[_MY_SIG_MAX+1] =
1670     {
1671         0,                  /*  0 ZERO     */
1672         SS$_HANGUP,         /*  1 SIGHUP   */
1673         SS$_CONTROLC,       /*  2 SIGINT   */
1674         SS$_CONTROLY,       /*  3 SIGQUIT  */
1675         SS$_RADRMOD,        /*  4 SIGILL   */
1676         SS$_BREAK,          /*  5 SIGTRAP  */
1677         SS$_OPCCUS,         /*  6 SIGABRT  */
1678         SS$_COMPAT,         /*  7 SIGEMT   */
1679 #ifdef __VAX
1680         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1681 #else
1682         SS$_HPARITH,        /*  8 SIGFPE AXP */
1683 #endif
1684         SS$_ABORT,          /*  9 SIGKILL  */
1685         SS$_ACCVIO,         /* 10 SIGBUS   */
1686         SS$_ACCVIO,         /* 11 SIGSEGV  */
1687         SS$_BADPARAM,       /* 12 SIGSYS   */
1688         SS$_NOMBX,          /* 13 SIGPIPE  */
1689         SS$_ASTFLT,         /* 14 SIGALRM  */
1690         4,                  /* 15 SIGTERM  */
1691         0,                  /* 16 SIGUSR1  */
1692         0                   /* 17 SIGUSR2  */
1693     };
1694
1695 #if __VMS_VER >= 60200000
1696     static int initted = 0;
1697     if (!initted) {
1698         initted = 1;
1699         sig_code[16] = C$_SIGUSR1;
1700         sig_code[17] = C$_SIGUSR2;
1701     }
1702 #endif
1703
1704     if (sig < _SIG_MIN) return 0;
1705     if (sig > _MY_SIG_MAX) return 0;
1706     return sig_code[sig];
1707 }
1708
1709 int
1710 Perl_my_kill(int pid, int sig)
1711 {
1712     dTHX;
1713     int iss;
1714     unsigned int code;
1715     int sys$sigprc(unsigned int *pidadr,
1716                      struct dsc$descriptor_s *prcname,
1717                      unsigned int code);
1718
1719      /* sig 0 means validate the PID */
1720     /*------------------------------*/
1721     if (sig == 0) {
1722         const unsigned long int jpicode = JPI$_PID;
1723         pid_t ret_pid;
1724         int status;
1725         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1726         if ($VMS_STATUS_SUCCESS(status))
1727            return 0;
1728         switch (status) {
1729         case SS$_NOSUCHNODE:
1730         case SS$_UNREACHABLE:
1731         case SS$_NONEXPR:
1732            errno = ESRCH;
1733            break;
1734         case SS$_NOPRIV:
1735            errno = EPERM;
1736            break;
1737         default:
1738            errno = EVMSERR;
1739         }
1740         vaxc$errno=status;
1741         return -1;
1742     }
1743
1744     code = Perl_sig_to_vmscondition(sig);
1745
1746     if (!code) {
1747         SETERRNO(EINVAL, SS$_BADPARAM);
1748         return -1;
1749     }
1750
1751     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1752      * signals are to be sent to multiple processes.
1753      *  pid = 0 - all processes in group except ones that the system exempts
1754      *  pid = -1 - all processes except ones that the system exempts
1755      *  pid = -n - all processes in group (abs(n)) except ...
1756      * For now, just report as not supported.
1757      */
1758
1759     if (pid <= 0) {
1760         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1761         return -1;
1762     }
1763
1764     iss = sys$sigprc((unsigned int *)&pid,0,code);
1765     if (iss&1) return 0;
1766
1767     switch (iss) {
1768       case SS$_NOPRIV:
1769         set_errno(EPERM);  break;
1770       case SS$_NONEXPR:
1771       case SS$_NOSUCHNODE:
1772       case SS$_UNREACHABLE:
1773         set_errno(ESRCH);  break;
1774       case SS$_INSFMEM:
1775         set_errno(ENOMEM); break;
1776       default:
1777         _ckvmssts(iss);
1778         set_errno(EVMSERR);
1779     }
1780     set_vaxc_errno(iss);
1781
1782     return -1;
1783 }
1784 #endif
1785
1786 /* Routine to convert a VMS status code to a UNIX status code.
1787 ** More tricky than it appears because of conflicting conventions with
1788 ** existing code.
1789 **
1790 ** VMS status codes are a bit mask, with the least significant bit set for
1791 ** success.
1792 **
1793 ** Special UNIX status of EVMSERR indicates that no translation is currently
1794 ** available, and programs should check the VMS status code.
1795 **
1796 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1797 ** decoding.
1798 */
1799
1800 #ifndef C_FACILITY_NO
1801 #define C_FACILITY_NO 0x350000
1802 #endif
1803 #ifndef DCL_IVVERB
1804 #define DCL_IVVERB 0x38090
1805 #endif
1806
1807 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1808 {
1809 int facility;
1810 int fac_sp;
1811 int msg_no;
1812 int msg_status;
1813 int unix_status;
1814
1815   /* Assume the best or the worst */
1816   if (vms_status & STS$M_SUCCESS)
1817     unix_status = 0;
1818   else
1819     unix_status = EVMSERR;
1820
1821   msg_status = vms_status & ~STS$M_CONTROL;
1822
1823   facility = vms_status & STS$M_FAC_NO;
1824   fac_sp = vms_status & STS$M_FAC_SP;
1825   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1826
1827   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1828     switch(msg_no) {
1829     case SS$_NORMAL:
1830         unix_status = 0;
1831         break;
1832     case SS$_ACCVIO:
1833         unix_status = EFAULT;
1834         break;
1835     case SS$_DEVOFFLINE:
1836         unix_status = EBUSY;
1837         break;
1838     case SS$_CLEARED:
1839         unix_status = ENOTCONN;
1840         break;
1841     case SS$_IVCHAN:
1842     case SS$_IVLOGNAM:
1843     case SS$_BADPARAM:
1844     case SS$_IVLOGTAB:
1845     case SS$_NOLOGNAM:
1846     case SS$_NOLOGTAB:
1847     case SS$_INVFILFOROP:
1848     case SS$_INVARG:
1849     case SS$_NOSUCHID:
1850     case SS$_IVIDENT:
1851         unix_status = EINVAL;
1852         break;
1853     case SS$_UNSUPPORTED:
1854         unix_status = ENOTSUP;
1855         break;
1856     case SS$_FILACCERR:
1857     case SS$_NOGRPPRV:
1858     case SS$_NOSYSPRV:
1859         unix_status = EACCES;
1860         break;
1861     case SS$_DEVICEFULL:
1862         unix_status = ENOSPC;
1863         break;
1864     case SS$_NOSUCHDEV:
1865         unix_status = ENODEV;
1866         break;
1867     case SS$_NOSUCHFILE:
1868     case SS$_NOSUCHOBJECT:
1869         unix_status = ENOENT;
1870         break;
1871     case SS$_ABORT:                                 /* Fatal case */
1872     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1873     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1874         unix_status = EINTR;
1875         break;
1876     case SS$_BUFFEROVF:
1877         unix_status = E2BIG;
1878         break;
1879     case SS$_INSFMEM:
1880         unix_status = ENOMEM;
1881         break;
1882     case SS$_NOPRIV:
1883         unix_status = EPERM;
1884         break;
1885     case SS$_NOSUCHNODE:
1886     case SS$_UNREACHABLE:
1887         unix_status = ESRCH;
1888         break;
1889     case SS$_NONEXPR:
1890         unix_status = ECHILD;
1891         break;
1892     default:
1893         if ((facility == 0) && (msg_no < 8)) {
1894           /* These are not real VMS status codes so assume that they are
1895           ** already UNIX status codes
1896           */
1897           unix_status = msg_no;
1898           break;
1899         }
1900     }
1901   }
1902   else {
1903     /* Translate a POSIX exit code to a UNIX exit code */
1904     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1905         unix_status = (msg_no & 0x07F8) >> 3;
1906     }
1907     else {
1908
1909          /* Documented traditional behavior for handling VMS child exits */
1910         /*--------------------------------------------------------------*/
1911         if (child_flag != 0) {
1912
1913              /* Success / Informational return 0 */
1914             /*----------------------------------*/
1915             if (msg_no & STS$K_SUCCESS)
1916                 return 0;
1917
1918              /* Warning returns 1 */
1919             /*-------------------*/
1920             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1921                 return 1;
1922
1923              /* Everything else pass through the severity bits */
1924             /*------------------------------------------------*/
1925             return (msg_no & STS$M_SEVERITY);
1926         }
1927
1928          /* Normal VMS status to ERRNO mapping attempt */
1929         /*--------------------------------------------*/
1930         switch(msg_status) {
1931         /* case RMS$_EOF: */ /* End of File */
1932         case RMS$_FNF:  /* File Not Found */
1933         case RMS$_DNF:  /* Dir Not Found */
1934                 unix_status = ENOENT;
1935                 break;
1936         case RMS$_RNF:  /* Record Not Found */
1937                 unix_status = ESRCH;
1938                 break;
1939         case RMS$_DIR:
1940                 unix_status = ENOTDIR;
1941                 break;
1942         case RMS$_DEV:
1943                 unix_status = ENODEV;
1944                 break;
1945         case RMS$_IFI:
1946         case RMS$_FAC:
1947         case RMS$_ISI:
1948                 unix_status = EBADF;
1949                 break;
1950         case RMS$_FEX:
1951                 unix_status = EEXIST;
1952                 break;
1953         case RMS$_SYN:
1954         case RMS$_FNM:
1955         case LIB$_INVSTRDES:
1956         case LIB$_INVARG:
1957         case LIB$_NOSUCHSYM:
1958         case LIB$_INVSYMNAM:
1959         case DCL_IVVERB:
1960                 unix_status = EINVAL;
1961                 break;
1962         case CLI$_BUFOVF:
1963         case RMS$_RTB:
1964         case CLI$_TKNOVF:
1965         case CLI$_RSLOVF:
1966                 unix_status = E2BIG;
1967                 break;
1968         case RMS$_PRV:  /* No privilege */
1969         case RMS$_ACC:  /* ACP file access failed */
1970         case RMS$_WLK:  /* Device write locked */
1971                 unix_status = EACCES;
1972                 break;
1973         /* case RMS$_NMF: */  /* No more files */
1974         }
1975     }
1976   }
1977
1978   return unix_status;
1979 }
1980
1981 /* Try to guess at what VMS error status should go with a UNIX errno
1982  * value.  This is hard to do as there could be many possible VMS
1983  * error statuses that caused the errno value to be set.
1984  */
1985
1986 int Perl_unix_status_to_vms(int unix_status)
1987 {
1988 int test_unix_status;
1989
1990      /* Trivial cases first */
1991     /*---------------------*/
1992     if (unix_status == EVMSERR)
1993         return vaxc$errno;
1994
1995      /* Is vaxc$errno sane? */
1996     /*---------------------*/
1997     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1998     if (test_unix_status == unix_status)
1999         return vaxc$errno;
2000
2001      /* If way out of range, must be VMS code already */
2002     /*-----------------------------------------------*/
2003     if (unix_status > EVMSERR)
2004         return unix_status;
2005
2006      /* If out of range, punt */
2007     /*-----------------------*/
2008     if (unix_status > __ERRNO_MAX)
2009         return SS$_ABORT;
2010
2011
2012      /* Ok, now we have to do it the hard way. */
2013     /*----------------------------------------*/
2014     switch(unix_status) {
2015     case 0:     return SS$_NORMAL;
2016     case EPERM: return SS$_NOPRIV;
2017     case ENOENT: return SS$_NOSUCHOBJECT;
2018     case ESRCH: return SS$_UNREACHABLE;
2019     case EINTR: return SS$_ABORT;
2020     /* case EIO: */
2021     /* case ENXIO:  */
2022     case E2BIG: return SS$_BUFFEROVF;
2023     /* case ENOEXEC */
2024     case EBADF: return RMS$_IFI;
2025     case ECHILD: return SS$_NONEXPR;
2026     /* case EAGAIN */
2027     case ENOMEM: return SS$_INSFMEM;
2028     case EACCES: return SS$_FILACCERR;
2029     case EFAULT: return SS$_ACCVIO;
2030     /* case ENOTBLK */
2031     case EBUSY: return SS$_DEVOFFLINE;
2032     case EEXIST: return RMS$_FEX;
2033     /* case EXDEV */
2034     case ENODEV: return SS$_NOSUCHDEV;
2035     case ENOTDIR: return RMS$_DIR;
2036     /* case EISDIR */
2037     case EINVAL: return SS$_INVARG;
2038     /* case ENFILE */
2039     /* case EMFILE */
2040     /* case ENOTTY */
2041     /* case ETXTBSY */
2042     /* case EFBIG */
2043     case ENOSPC: return SS$_DEVICEFULL;
2044     case ESPIPE: return LIB$_INVARG;
2045     /* case EROFS: */
2046     /* case EMLINK: */
2047     /* case EPIPE: */
2048     /* case EDOM */
2049     case ERANGE: return LIB$_INVARG;
2050     /* case EWOULDBLOCK */
2051     /* case EINPROGRESS */
2052     /* case EALREADY */
2053     /* case ENOTSOCK */
2054     /* case EDESTADDRREQ */
2055     /* case EMSGSIZE */
2056     /* case EPROTOTYPE */
2057     /* case ENOPROTOOPT */
2058     /* case EPROTONOSUPPORT */
2059     /* case ESOCKTNOSUPPORT */
2060     /* case EOPNOTSUPP */
2061     /* case EPFNOSUPPORT */
2062     /* case EAFNOSUPPORT */
2063     /* case EADDRINUSE */
2064     /* case EADDRNOTAVAIL */
2065     /* case ENETDOWN */
2066     /* case ENETUNREACH */
2067     /* case ENETRESET */
2068     /* case ECONNABORTED */
2069     /* case ECONNRESET */
2070     /* case ENOBUFS */
2071     /* case EISCONN */
2072     case ENOTCONN: return SS$_CLEARED;
2073     /* case ESHUTDOWN */
2074     /* case ETOOMANYREFS */
2075     /* case ETIMEDOUT */
2076     /* case ECONNREFUSED */
2077     /* case ELOOP */
2078     /* case ENAMETOOLONG */
2079     /* case EHOSTDOWN */
2080     /* case EHOSTUNREACH */
2081     /* case ENOTEMPTY */
2082     /* case EPROCLIM */
2083     /* case EUSERS  */
2084     /* case EDQUOT  */
2085     /* case ENOMSG  */
2086     /* case EIDRM */
2087     /* case EALIGN */
2088     /* case ESTALE */
2089     /* case EREMOTE */
2090     /* case ENOLCK */
2091     /* case ENOSYS */
2092     /* case EFTYPE */
2093     /* case ECANCELED */
2094     /* case EFAIL */
2095     /* case EINPROG */
2096     case ENOTSUP:
2097         return SS$_UNSUPPORTED;
2098     /* case EDEADLK */
2099     /* case ENWAIT */
2100     /* case EILSEQ */
2101     /* case EBADCAT */
2102     /* case EBADMSG */
2103     /* case EABANDONED */
2104     default:
2105         return SS$_ABORT; /* punt */
2106     }
2107
2108   return SS$_ABORT; /* Should not get here */
2109 }
2110
2111
2112 /* default piping mailbox size */
2113 #define PERL_BUFSIZ        512
2114
2115
2116 static void
2117 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2118 {
2119   unsigned long int mbxbufsiz;
2120   static unsigned long int syssize = 0;
2121   unsigned long int dviitm = DVI$_DEVNAM;
2122   char csize[LNM$C_NAMLENGTH+1];
2123   int sts;
2124
2125   if (!syssize) {
2126     unsigned long syiitm = SYI$_MAXBUF;
2127     /*
2128      * Get the SYSGEN parameter MAXBUF
2129      *
2130      * If the logical 'PERL_MBX_SIZE' is defined
2131      * use the value of the logical instead of PERL_BUFSIZ, but
2132      * keep the size between 128 and MAXBUF.
2133      *
2134      */
2135     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2136   }
2137
2138   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2139       mbxbufsiz = atoi(csize);
2140   } else {
2141       mbxbufsiz = PERL_BUFSIZ;
2142   }
2143   if (mbxbufsiz < 128) mbxbufsiz = 128;
2144   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2145
2146   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2147
2148   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2149   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2150
2151 }  /* end of create_mbx() */
2152
2153
2154 /*{{{  my_popen and my_pclose*/
2155
2156 typedef struct _iosb           IOSB;
2157 typedef struct _iosb*         pIOSB;
2158 typedef struct _pipe           Pipe;
2159 typedef struct _pipe*         pPipe;
2160 typedef struct pipe_details    Info;
2161 typedef struct pipe_details*  pInfo;
2162 typedef struct _srqp            RQE;
2163 typedef struct _srqp*          pRQE;
2164 typedef struct _tochildbuf      CBuf;
2165 typedef struct _tochildbuf*    pCBuf;
2166
2167 struct _iosb {
2168     unsigned short status;
2169     unsigned short count;
2170     unsigned long  dvispec;
2171 };
2172
2173 #pragma member_alignment save
2174 #pragma nomember_alignment quadword
2175 struct _srqp {          /* VMS self-relative queue entry */
2176     unsigned long qptr[2];
2177 };
2178 #pragma member_alignment restore
2179 static RQE  RQE_ZERO = {0,0};
2180
2181 struct _tochildbuf {
2182     RQE             q;
2183     int             eof;
2184     unsigned short  size;
2185     char            *buf;
2186 };
2187
2188 struct _pipe {
2189     RQE            free;
2190     RQE            wait;
2191     int            fd_out;
2192     unsigned short chan_in;
2193     unsigned short chan_out;
2194     char          *buf;
2195     unsigned int   bufsize;
2196     IOSB           iosb;
2197     IOSB           iosb2;
2198     int           *pipe_done;
2199     int            retry;
2200     int            type;
2201     int            shut_on_empty;
2202     int            need_wake;
2203     pPipe         *home;
2204     pInfo          info;
2205     pCBuf          curr;
2206     pCBuf          curr2;
2207 #if defined(PERL_IMPLICIT_CONTEXT)
2208     void            *thx;           /* Either a thread or an interpreter */
2209                                     /* pointer, depending on how we're built */
2210 #endif
2211 };
2212
2213
2214 struct pipe_details
2215 {
2216     pInfo           next;
2217     PerlIO *fp;  /* file pointer to pipe mailbox */
2218     int useFILE; /* using stdio, not perlio */
2219     int pid;   /* PID of subprocess */
2220     int mode;  /* == 'r' if pipe open for reading */
2221     int done;  /* subprocess has completed */
2222     int waiting; /* waiting for completion/closure */
2223     int             closing;        /* my_pclose is closing this pipe */
2224     unsigned long   completion;     /* termination status of subprocess */
2225     pPipe           in;             /* pipe in to sub */
2226     pPipe           out;            /* pipe out of sub */
2227     pPipe           err;            /* pipe of sub's sys$error */
2228     int             in_done;        /* true when in pipe finished */
2229     int             out_done;
2230     int             err_done;
2231 };
2232
2233 struct exit_control_block
2234 {
2235     struct exit_control_block *flink;
2236     unsigned long int   (*exit_routine)();
2237     unsigned long int arg_count;
2238     unsigned long int *status_address;
2239     unsigned long int exit_status;
2240 };
2241
2242 typedef struct _closed_pipes    Xpipe;
2243 typedef struct _closed_pipes*  pXpipe;
2244
2245 struct _closed_pipes {
2246     int             pid;            /* PID of subprocess */
2247     unsigned long   completion;     /* termination status of subprocess */
2248 };
2249 #define NKEEPCLOSED 50
2250 static Xpipe closed_list[NKEEPCLOSED];
2251 static int   closed_index = 0;
2252 static int   closed_num = 0;
2253
2254 #define RETRY_DELAY     "0 ::0.20"
2255 #define MAX_RETRY              50
2256
2257 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2258 static unsigned long mypid;
2259 static unsigned long delaytime[2];
2260
2261 static pInfo open_pipes = NULL;
2262 static $DESCRIPTOR(nl_desc, "NL:");
2263
2264 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2265
2266
2267
2268 static unsigned long int
2269 pipe_exit_routine(pTHX)
2270 {
2271     pInfo info;
2272     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2273     int sts, did_stuff, need_eof, j;
2274
2275     /*
2276         flush any pending i/o
2277     */
2278     info = open_pipes;
2279     while (info) {
2280         if (info->fp) {
2281            if (!info->useFILE)
2282                PerlIO_flush(info->fp);   /* first, flush data */
2283            else
2284                fflush((FILE *)info->fp);
2285         }
2286         info = info->next;
2287     }
2288
2289     /*
2290      next we try sending an EOF...ignore if doesn't work, make sure we
2291      don't hang
2292     */
2293     did_stuff = 0;
2294     info = open_pipes;
2295
2296     while (info) {
2297       int need_eof;
2298       _ckvmssts_noperl(sys$setast(0));
2299       if (info->in && !info->in->shut_on_empty) {
2300         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2301                           0, 0, 0, 0, 0, 0));
2302         info->waiting = 1;
2303         did_stuff = 1;
2304       }
2305       _ckvmssts_noperl(sys$setast(1));
2306       info = info->next;
2307     }
2308
2309     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2310
2311     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2312         int nwait = 0;
2313
2314         info = open_pipes;
2315         while (info) {
2316           _ckvmssts_noperl(sys$setast(0));
2317           if (info->waiting && info->done)
2318                 info->waiting = 0;
2319           nwait += info->waiting;
2320           _ckvmssts_noperl(sys$setast(1));
2321           info = info->next;
2322         }
2323         if (!nwait) break;
2324         sleep(1);
2325     }
2326
2327     did_stuff = 0;
2328     info = open_pipes;
2329     while (info) {
2330       _ckvmssts_noperl(sys$setast(0));
2331       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2332         sts = sys$forcex(&info->pid,0,&abort);
2333         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2334         did_stuff = 1;
2335       }
2336       _ckvmssts_noperl(sys$setast(1));
2337       info = info->next;
2338     }
2339
2340     /* again, wait for effect */
2341
2342     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2343         int nwait = 0;
2344
2345         info = open_pipes;
2346         while (info) {
2347           _ckvmssts_noperl(sys$setast(0));
2348           if (info->waiting && info->done)
2349                 info->waiting = 0;
2350           nwait += info->waiting;
2351           _ckvmssts_noperl(sys$setast(1));
2352           info = info->next;
2353         }
2354         if (!nwait) break;
2355         sleep(1);
2356     }
2357
2358     info = open_pipes;
2359     while (info) {
2360       _ckvmssts_noperl(sys$setast(0));
2361       if (!info->done) {  /* We tried to be nice . . . */
2362         sts = sys$delprc(&info->pid,0);
2363         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2364       }
2365       _ckvmssts_noperl(sys$setast(1));
2366       info = info->next;
2367     }
2368
2369     while(open_pipes) {
2370       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2371       else if (!(sts & 1)) retsts = sts;
2372     }
2373     return retsts;
2374 }
2375
2376 static struct exit_control_block pipe_exitblock =
2377        {(struct exit_control_block *) 0,
2378         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2379
2380 static void pipe_mbxtofd_ast(pPipe p);
2381 static void pipe_tochild1_ast(pPipe p);
2382 static void pipe_tochild2_ast(pPipe p);
2383
2384 static void
2385 popen_completion_ast(pInfo info)
2386 {
2387   pInfo i = open_pipes;
2388   int iss;
2389   int sts;
2390   pXpipe x;
2391
2392   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2393   closed_list[closed_index].pid = info->pid;
2394   closed_list[closed_index].completion = info->completion;
2395   closed_index++;
2396   if (closed_index == NKEEPCLOSED)
2397     closed_index = 0;
2398   closed_num++;
2399
2400   while (i) {
2401     if (i == info) break;
2402     i = i->next;
2403   }
2404   if (!i) return;       /* unlinked, probably freed too */
2405
2406   info->done = TRUE;
2407
2408 /*
2409     Writing to subprocess ...
2410             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2411
2412             chan_out may be waiting for "done" flag, or hung waiting
2413             for i/o completion to child...cancel the i/o.  This will
2414             put it into "snarf mode" (done but no EOF yet) that discards
2415             input.
2416
2417     Output from subprocess (stdout, stderr) needs to be flushed and
2418     shut down.   We try sending an EOF, but if the mbx is full the pipe
2419     routine should still catch the "shut_on_empty" flag, telling it to
2420     use immediate-style reads so that "mbx empty" -> EOF.
2421
2422
2423 */
2424   if (info->in && !info->in_done) {               /* only for mode=w */
2425         if (info->in->shut_on_empty && info->in->need_wake) {
2426             info->in->need_wake = FALSE;
2427             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2428         } else {
2429             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2430         }
2431   }
2432
2433   if (info->out && !info->out_done) {             /* were we also piping output? */
2434       info->out->shut_on_empty = TRUE;
2435       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2436       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2437       _ckvmssts_noperl(iss);
2438   }
2439
2440   if (info->err && !info->err_done) {        /* we were piping stderr */
2441         info->err->shut_on_empty = TRUE;
2442         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2443         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2444         _ckvmssts_noperl(iss);
2445   }
2446   _ckvmssts_noperl(sys$setef(pipe_ef));
2447
2448 }
2449
2450 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2451 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2452
2453 /*
2454     we actually differ from vmstrnenv since we use this to
2455     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2456     are pointing to the same thing
2457 */
2458
2459 static unsigned short
2460 popen_translate(pTHX_ char *logical, char *result)
2461 {
2462     int iss;
2463     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2464     $DESCRIPTOR(d_log,"");
2465     struct _il3 {
2466         unsigned short length;
2467         unsigned short code;
2468         char *         buffer_addr;
2469         unsigned short *retlenaddr;
2470     } itmlst[2];
2471     unsigned short l, ifi;
2472
2473     d_log.dsc$a_pointer = logical;
2474     d_log.dsc$w_length  = strlen(logical);
2475
2476     itmlst[0].code = LNM$_STRING;
2477     itmlst[0].length = 255;
2478     itmlst[0].buffer_addr = result;
2479     itmlst[0].retlenaddr = &l;
2480
2481     itmlst[1].code = 0;
2482     itmlst[1].length = 0;
2483     itmlst[1].buffer_addr = 0;
2484     itmlst[1].retlenaddr = 0;
2485
2486     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2487     if (iss == SS$_NOLOGNAM) {
2488         iss = SS$_NORMAL;
2489         l = 0;
2490     }
2491     if (!(iss&1)) lib$signal(iss);
2492     result[l] = '\0';
2493 /*
2494     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2495     strip it off and return the ifi, if any
2496 */
2497     ifi  = 0;
2498     if (result[0] == 0x1b && result[1] == 0x00) {
2499         memmove(&ifi,result+2,2);
2500         strcpy(result,result+4);
2501     }
2502     return ifi;     /* this is the RMS internal file id */
2503 }
2504
2505 static void pipe_infromchild_ast(pPipe p);
2506
2507 /*
2508     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2509     inside an AST routine without worrying about reentrancy and which Perl
2510     memory allocator is being used.
2511
2512     We read data and queue up the buffers, then spit them out one at a
2513     time to the output mailbox when the output mailbox is ready for one.
2514
2515 */
2516 #define INITIAL_TOCHILDQUEUE  2
2517
2518 static pPipe
2519 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2520 {
2521     pPipe p;
2522     pCBuf b;
2523     char mbx1[64], mbx2[64];
2524     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2525                                       DSC$K_CLASS_S, mbx1},
2526                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2527                                       DSC$K_CLASS_S, mbx2};
2528     unsigned int dviitm = DVI$_DEVBUFSIZ;
2529     int j, n;
2530
2531     n = sizeof(Pipe);
2532     _ckvmssts(lib$get_vm(&n, &p));
2533
2534     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2535     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2536     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2537
2538     p->buf           = 0;
2539     p->shut_on_empty = FALSE;
2540     p->need_wake     = FALSE;
2541     p->type          = 0;
2542     p->retry         = 0;
2543     p->iosb.status   = SS$_NORMAL;
2544     p->iosb2.status  = SS$_NORMAL;
2545     p->free          = RQE_ZERO;
2546     p->wait          = RQE_ZERO;
2547     p->curr          = 0;
2548     p->curr2         = 0;
2549     p->info          = 0;
2550 #ifdef PERL_IMPLICIT_CONTEXT
2551     p->thx           = aTHX;
2552 #endif
2553
2554     n = sizeof(CBuf) + p->bufsize;
2555
2556     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2557         _ckvmssts(lib$get_vm(&n, &b));
2558         b->buf = (char *) b + sizeof(CBuf);
2559         _ckvmssts(lib$insqhi(b, &p->free));
2560     }
2561
2562     pipe_tochild2_ast(p);
2563     pipe_tochild1_ast(p);
2564     strcpy(wmbx, mbx1);
2565     strcpy(rmbx, mbx2);
2566     return p;
2567 }
2568
2569 /*  reads the MBX Perl is writing, and queues */
2570
2571 static void
2572 pipe_tochild1_ast(pPipe p)
2573 {
2574     pCBuf b = p->curr;
2575     int iss = p->iosb.status;
2576     int eof = (iss == SS$_ENDOFFILE);
2577     int sts;
2578 #ifdef PERL_IMPLICIT_CONTEXT
2579     pTHX = p->thx;
2580 #endif
2581
2582     if (p->retry) {
2583         if (eof) {
2584             p->shut_on_empty = TRUE;
2585             b->eof     = TRUE;
2586             _ckvmssts(sys$dassgn(p->chan_in));
2587         } else  {
2588             _ckvmssts(iss);
2589         }
2590
2591         b->eof  = eof;
2592         b->size = p->iosb.count;
2593         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2594         if (p->need_wake) {
2595             p->need_wake = FALSE;
2596             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2597         }
2598     } else {
2599         p->retry = 1;   /* initial call */
2600     }
2601
2602     if (eof) {                  /* flush the free queue, return when done */
2603         int n = sizeof(CBuf) + p->bufsize;
2604         while (1) {
2605             iss = lib$remqti(&p->free, &b);
2606             if (iss == LIB$_QUEWASEMP) return;
2607             _ckvmssts(iss);
2608             _ckvmssts(lib$free_vm(&n, &b));
2609         }
2610     }
2611
2612     iss = lib$remqti(&p->free, &b);
2613     if (iss == LIB$_QUEWASEMP) {
2614         int n = sizeof(CBuf) + p->bufsize;
2615         _ckvmssts(lib$get_vm(&n, &b));
2616         b->buf = (char *) b + sizeof(CBuf);
2617     } else {
2618        _ckvmssts(iss);
2619     }
2620
2621     p->curr = b;
2622     iss = sys$qio(0,p->chan_in,
2623              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2624              &p->iosb,
2625              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2626     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2627     _ckvmssts(iss);
2628 }
2629
2630
2631 /* writes queued buffers to output, waits for each to complete before
2632    doing the next */
2633
2634 static void
2635 pipe_tochild2_ast(pPipe p)
2636 {
2637     pCBuf b = p->curr2;
2638     int iss = p->iosb2.status;
2639     int n = sizeof(CBuf) + p->bufsize;
2640     int done = (p->info && p->info->done) ||
2641               iss == SS$_CANCEL || iss == SS$_ABORT;
2642 #if defined(PERL_IMPLICIT_CONTEXT)
2643     pTHX = p->thx;
2644 #endif
2645
2646     do {
2647         if (p->type) {         /* type=1 has old buffer, dispose */
2648             if (p->shut_on_empty) {
2649                 _ckvmssts(lib$free_vm(&n, &b));
2650             } else {
2651                 _ckvmssts(lib$insqhi(b, &p->free));
2652             }
2653             p->type = 0;
2654         }
2655
2656         iss = lib$remqti(&p->wait, &b);
2657         if (iss == LIB$_QUEWASEMP) {
2658             if (p->shut_on_empty) {
2659                 if (done) {
2660                     _ckvmssts(sys$dassgn(p->chan_out));
2661                     *p->pipe_done = TRUE;
2662                     _ckvmssts(sys$setef(pipe_ef));
2663                 } else {
2664                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2665                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2666                 }
2667                 return;
2668             }
2669             p->need_wake = TRUE;
2670             return;
2671         }
2672         _ckvmssts(iss);
2673         p->type = 1;
2674     } while (done);
2675
2676
2677     p->curr2 = b;
2678     if (b->eof) {
2679         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2680             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2681     } else {
2682         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2683             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2684     }
2685
2686     return;
2687
2688 }
2689
2690
2691 static pPipe
2692 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2693 {
2694     pPipe p;
2695     char mbx1[64], mbx2[64];
2696     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2697                                       DSC$K_CLASS_S, mbx1},
2698                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2699                                       DSC$K_CLASS_S, mbx2};
2700     unsigned int dviitm = DVI$_DEVBUFSIZ;
2701
2702     int n = sizeof(Pipe);
2703     _ckvmssts(lib$get_vm(&n, &p));
2704     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2705     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2706
2707     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2708     n = p->bufsize * sizeof(char);
2709     _ckvmssts(lib$get_vm(&n, &p->buf));
2710     p->shut_on_empty = FALSE;
2711     p->info   = 0;
2712     p->type   = 0;
2713     p->iosb.status = SS$_NORMAL;
2714 #if defined(PERL_IMPLICIT_CONTEXT)
2715     p->thx = aTHX;
2716 #endif
2717     pipe_infromchild_ast(p);
2718
2719     strcpy(wmbx, mbx1);
2720     strcpy(rmbx, mbx2);
2721     return p;
2722 }
2723
2724 static void
2725 pipe_infromchild_ast(pPipe p)
2726 {
2727     int iss = p->iosb.status;
2728     int eof = (iss == SS$_ENDOFFILE);
2729     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2730     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2731 #if defined(PERL_IMPLICIT_CONTEXT)
2732     pTHX = p->thx;
2733 #endif
2734
2735     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2736         _ckvmssts(sys$dassgn(p->chan_out));
2737         p->chan_out = 0;
2738     }
2739
2740     /* read completed:
2741             input shutdown if EOF from self (done or shut_on_empty)
2742             output shutdown if closing flag set (my_pclose)
2743             send data/eof from child or eof from self
2744             otherwise, re-read (snarf of data from child)
2745     */
2746
2747     if (p->type == 1) {
2748         p->type = 0;
2749         if (myeof && p->chan_in) {                  /* input shutdown */
2750             _ckvmssts(sys$dassgn(p->chan_in));
2751             p->chan_in = 0;
2752         }
2753
2754         if (p->chan_out) {
2755             if (myeof || kideof) {      /* pass EOF to parent */
2756                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2757                               pipe_infromchild_ast, p,
2758                               0, 0, 0, 0, 0, 0));
2759                 return;
2760             } else if (eof) {       /* eat EOF --- fall through to read*/
2761
2762             } else {                /* transmit data */
2763                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2764                               pipe_infromchild_ast,p,
2765                               p->buf, p->iosb.count, 0, 0, 0, 0));
2766                 return;
2767             }
2768         }
2769     }
2770
2771     /*  everything shut? flag as done */
2772
2773     if (!p->chan_in && !p->chan_out) {
2774         *p->pipe_done = TRUE;
2775         _ckvmssts(sys$setef(pipe_ef));
2776         return;
2777     }
2778
2779     /* write completed (or read, if snarfing from child)
2780             if still have input active,
2781                queue read...immediate mode if shut_on_empty so we get EOF if empty
2782             otherwise,
2783                check if Perl reading, generate EOFs as needed
2784     */
2785
2786     if (p->type == 0) {
2787         p->type = 1;
2788         if (p->chan_in) {
2789             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2790                           pipe_infromchild_ast,p,
2791                           p->buf, p->bufsize, 0, 0, 0, 0);
2792             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2793             _ckvmssts(iss);
2794         } else {           /* send EOFs for extra reads */
2795             p->iosb.status = SS$_ENDOFFILE;
2796             p->iosb.dvispec = 0;
2797             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2798                       0, 0, 0,
2799                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2800         }
2801     }
2802 }
2803
2804 static pPipe
2805 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2806 {
2807     pPipe p;
2808     char mbx[64];
2809     unsigned long dviitm = DVI$_DEVBUFSIZ;
2810     struct stat s;
2811     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2812                                       DSC$K_CLASS_S, mbx};
2813     int n = sizeof(Pipe);
2814
2815     /* things like terminals and mbx's don't need this filter */
2816     if (fd && fstat(fd,&s) == 0) {
2817         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2818         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2819                                          DSC$K_CLASS_S, s.st_dev};
2820
2821         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2822         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2823             strcpy(out, s.st_dev);
2824             return 0;
2825         }
2826     }
2827
2828     _ckvmssts(lib$get_vm(&n, &p));
2829     p->fd_out = dup(fd);
2830     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2831     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2832     n = (p->bufsize+1) * sizeof(char);
2833     _ckvmssts(lib$get_vm(&n, &p->buf));
2834     p->shut_on_empty = FALSE;
2835     p->retry = 0;
2836     p->info  = 0;
2837     strcpy(out, mbx);
2838
2839     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2840                   pipe_mbxtofd_ast, p,
2841                   p->buf, p->bufsize, 0, 0, 0, 0));
2842
2843     return p;
2844 }
2845
2846 static void
2847 pipe_mbxtofd_ast(pPipe p)
2848 {
2849     int iss = p->iosb.status;
2850     int done = p->info->done;
2851     int iss2;
2852     int eof = (iss == SS$_ENDOFFILE);
2853     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2854     int err = !(iss&1) && !eof;
2855 #if defined(PERL_IMPLICIT_CONTEXT)
2856     pTHX = p->thx;
2857 #endif
2858
2859     if (done && myeof) {               /* end piping */
2860         close(p->fd_out);
2861         sys$dassgn(p->chan_in);
2862         *p->pipe_done = TRUE;
2863         _ckvmssts(sys$setef(pipe_ef));
2864         return;
2865     }
2866
2867     if (!err && !eof) {             /* good data to send to file */
2868         p->buf[p->iosb.count] = '\n';
2869         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2870         if (iss2 < 0) {
2871             p->retry++;
2872             if (p->retry < MAX_RETRY) {
2873                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2874                 return;
2875             }
2876         }
2877         p->retry = 0;
2878     } else if (err) {
2879         _ckvmssts(iss);
2880     }
2881
2882
2883     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2884           pipe_mbxtofd_ast, p,
2885           p->buf, p->bufsize, 0, 0, 0, 0);
2886     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2887     _ckvmssts(iss);
2888 }
2889
2890
2891 typedef struct _pipeloc     PLOC;
2892 typedef struct _pipeloc*   pPLOC;
2893
2894 struct _pipeloc {
2895     pPLOC   next;
2896     char    dir[NAM$C_MAXRSS+1];
2897 };
2898 static pPLOC  head_PLOC = 0;
2899
2900 void
2901 free_pipelocs(pTHX_ void *head)
2902 {
2903     pPLOC p, pnext;
2904     pPLOC *pHead = (pPLOC *)head;
2905
2906     p = *pHead;
2907     while (p) {
2908         pnext = p->next;
2909         PerlMem_free(p);
2910         p = pnext;
2911     }
2912     *pHead = 0;
2913 }
2914
2915 static void
2916 store_pipelocs(pTHX)
2917 {
2918     int    i;
2919     pPLOC  p;
2920     AV    *av = 0;
2921     SV    *dirsv;
2922     GV    *gv;
2923     char  *dir, *x;
2924     char  *unixdir;
2925     char  temp[NAM$C_MAXRSS+1];
2926     STRLEN n_a;
2927
2928     if (head_PLOC)
2929         free_pipelocs(aTHX_ &head_PLOC);
2930
2931 /*  the . directory from @INC comes last */
2932
2933     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2934     p->next = head_PLOC;
2935     head_PLOC = p;
2936     strcpy(p->dir,"./");
2937
2938 /*  get the directory from $^X */
2939
2940 #ifdef PERL_IMPLICIT_CONTEXT
2941     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2942 #else
2943     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2944 #endif
2945         strcpy(temp, PL_origargv[0]);
2946         x = strrchr(temp,']');
2947         if (x == NULL) {
2948         x = strrchr(temp,'>');
2949           if (x == NULL) {
2950             /* It could be a UNIX path */
2951             x = strrchr(temp,'/');
2952           }
2953         }
2954         if (x)
2955           x[1] = '\0';
2956         else {
2957           /* Got a bare name, so use default directory */
2958           temp[0] = '.';
2959           temp[1] = '\0';
2960         }
2961
2962         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2963             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2964             p->next = head_PLOC;
2965             head_PLOC = p;
2966             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2967             p->dir[NAM$C_MAXRSS] = '\0';
2968         }
2969     }
2970
2971 /*  reverse order of @INC entries, skip "." since entered above */
2972
2973 #ifdef PERL_IMPLICIT_CONTEXT
2974     if (aTHX)
2975 #endif
2976     if (PL_incgv) av = GvAVn(PL_incgv);
2977
2978     for (i = 0; av && i <= AvFILL(av); i++) {
2979         dirsv = *av_fetch(av,i,TRUE);
2980
2981         if (SvROK(dirsv)) continue;
2982         dir = SvPVx(dirsv,n_a);
2983         if (strcmp(dir,".") == 0) continue;
2984         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2985             continue;
2986
2987         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2988         p->next = head_PLOC;
2989         head_PLOC = p;
2990         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2991         p->dir[NAM$C_MAXRSS] = '\0';
2992     }
2993
2994 /* most likely spot (ARCHLIB) put first in the list */
2995
2996 #ifdef ARCHLIB_EXP
2997     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2998         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2999         p->next = head_PLOC;
3000         head_PLOC = p;
3001         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3002         p->dir[NAM$C_MAXRSS] = '\0';
3003     }
3004 #endif
3005 }
3006
3007
3008 static char *
3009 find_vmspipe(pTHX)
3010 {
3011     static int   vmspipe_file_status = 0;
3012     static char  vmspipe_file[NAM$C_MAXRSS+1];
3013
3014     /* already found? Check and use ... need read+execute permission */
3015
3016     if (vmspipe_file_status == 1) {
3017         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3018          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3019             return vmspipe_file;
3020         }
3021         vmspipe_file_status = 0;
3022     }
3023
3024     /* scan through stored @INC, $^X */
3025
3026     if (vmspipe_file_status == 0) {
3027         char file[NAM$C_MAXRSS+1];
3028         pPLOC  p = head_PLOC;
3029
3030         while (p) {
3031             strcpy(file, p->dir);
3032             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3033             file[NAM$C_MAXRSS] = '\0';
3034             p = p->next;
3035
3036             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3037
3038             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3039              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3040                 vmspipe_file_status = 1;
3041                 return vmspipe_file;
3042             }
3043         }
3044         vmspipe_file_status = -1;   /* failed, use tempfiles */
3045     }
3046
3047     return 0;
3048 }
3049
3050 static FILE *
3051 vmspipe_tempfile(pTHX)
3052 {
3053     char file[NAM$C_MAXRSS+1];
3054     FILE *fp;
3055     static int index = 0;
3056     Stat_t s0, s1;
3057     int cmp_result;
3058
3059     /* create a tempfile */
3060
3061     /* we can't go from   W, shr=get to  R, shr=get without
3062        an intermediate vulnerable state, so don't bother trying...
3063
3064        and lib$spawn doesn't shr=put, so have to close the write
3065
3066        So... match up the creation date/time and the FID to
3067        make sure we're dealing with the same file
3068
3069     */
3070
3071     index++;
3072     if (!decc_filename_unix_only) {
3073       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3074       fp = fopen(file,"w");
3075       if (!fp) {
3076         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3077         fp = fopen(file,"w");
3078         if (!fp) {
3079             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3080             fp = fopen(file,"w");
3081         }
3082       }
3083      }
3084      else {
3085       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3086       fp = fopen(file,"w");
3087       if (!fp) {
3088         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3089         fp = fopen(file,"w");
3090         if (!fp) {
3091           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3092           fp = fopen(file,"w");
3093         }
3094       }
3095     }
3096     if (!fp) return 0;  /* we're hosed */
3097
3098     fprintf(fp,"$! 'f$verify(0)'\n");
3099     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3100     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3101     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3102     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3103     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3104     fprintf(fp,"$ perl_del    = \"delete\"\n");
3105     fprintf(fp,"$ pif         = \"if\"\n");
3106     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3107     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3108     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3109     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3110     fprintf(fp,"$!  --- build command line to get max possible length\n");
3111     fprintf(fp,"$c=perl_popen_cmd0\n");
3112     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3113     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3114     fprintf(fp,"$x=perl_popen_cmd3\n");
3115     fprintf(fp,"$c=c+x\n");
3116     fprintf(fp,"$ perl_on\n");
3117     fprintf(fp,"$ 'c'\n");
3118     fprintf(fp,"$ perl_status = $STATUS\n");
3119     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3120     fprintf(fp,"$ perl_exit 'perl_status'\n");
3121     fsync(fileno(fp));
3122
3123     fgetname(fp, file, 1);
3124     fstat(fileno(fp), (struct stat *)&s0);
3125     fclose(fp);
3126
3127     if (decc_filename_unix_only)
3128         do_tounixspec(file, file, 0);
3129     fp = fopen(file,"r","shr=get");
3130     if (!fp) return 0;
3131     fstat(fileno(fp), (struct stat *)&s1);
3132
3133     #if defined(_USE_STD_STAT)
3134       cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3135     #else
3136       cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3137     #endif
3138     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3139         fclose(fp);
3140         return 0;
3141     }
3142
3143     return fp;
3144 }
3145
3146
3147
3148 static PerlIO *
3149 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3150 {
3151     static int handler_set_up = FALSE;
3152     unsigned long int sts, flags = CLI$M_NOWAIT;
3153     /* The use of a GLOBAL table (as was done previously) rendered
3154      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3155      * environment.  Hence we've switched to LOCAL symbol table.
3156      */
3157     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3158     int j, wait = 0, n;
3159     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3160     char in[512], out[512], err[512], mbx[512];
3161     FILE *tpipe = 0;
3162     char tfilebuf[NAM$C_MAXRSS+1];
3163     pInfo info = NULL;
3164     char cmd_sym_name[20];
3165     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3166                                       DSC$K_CLASS_S, symbol};
3167     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3168                                       DSC$K_CLASS_S, 0};
3169     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3170                                       DSC$K_CLASS_S, cmd_sym_name};
3171     struct dsc$descriptor_s *vmscmd;
3172     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3173     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3174     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3175
3176     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3177
3178     /* once-per-program initialization...
3179        note that the SETAST calls and the dual test of pipe_ef
3180        makes sure that only the FIRST thread through here does
3181        the initialization...all other threads wait until it's
3182        done.
3183
3184        Yeah, uglier than a pthread call, it's got all the stuff inline
3185        rather than in a separate routine.
3186     */
3187
3188     if (!pipe_ef) {
3189         _ckvmssts(sys$setast(0));
3190         if (!pipe_ef) {
3191             unsigned long int pidcode = JPI$_PID;
3192             $DESCRIPTOR(d_delay, RETRY_DELAY);
3193             _ckvmssts(lib$get_ef(&pipe_ef));
3194             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3195             _ckvmssts(sys$bintim(&d_delay, delaytime));
3196         }
3197         if (!handler_set_up) {
3198           _ckvmssts(sys$dclexh(&pipe_exitblock));
3199           handler_set_up = TRUE;
3200         }
3201         _ckvmssts(sys$setast(1));
3202     }
3203
3204     /* see if we can find a VMSPIPE.COM */
3205
3206     tfilebuf[0] = '@';
3207     vmspipe = find_vmspipe(aTHX);
3208     if (vmspipe) {
3209         strcpy(tfilebuf+1,vmspipe);
3210     } else {        /* uh, oh...we're in tempfile hell */
3211         tpipe = vmspipe_tempfile(aTHX);
3212         if (!tpipe) {       /* a fish popular in Boston */
3213             if (ckWARN(WARN_PIPE)) {
3214                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3215             }
3216         return Nullfp;
3217         }
3218         fgetname(tpipe,tfilebuf+1,1);
3219     }
3220     vmspipedsc.dsc$a_pointer = tfilebuf;
3221     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3222
3223     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3224     if (!(sts & 1)) {
3225       switch (sts) {
3226         case RMS$_FNF:  case RMS$_DNF:
3227           set_errno(ENOENT); break;
3228         case RMS$_DIR:
3229           set_errno(ENOTDIR); break;
3230         case RMS$_DEV:
3231           set_errno(ENODEV); break;
3232         case RMS$_PRV:
3233           set_errno(EACCES); break;
3234         case RMS$_SYN:
3235           set_errno(EINVAL); break;
3236         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3237           set_errno(E2BIG); break;
3238         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3239           _ckvmssts(sts); /* fall through */
3240         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3241           set_errno(EVMSERR);
3242       }
3243       set_vaxc_errno(sts);
3244       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3245         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3246       }
3247       *psts = sts;
3248       return Nullfp;
3249     }
3250     n = sizeof(Info);
3251     _ckvmssts(lib$get_vm(&n, &info));
3252
3253     strcpy(mode,in_mode);
3254     info->mode = *mode;
3255     info->done = FALSE;
3256     info->completion = 0;
3257     info->closing    = FALSE;
3258     info->in         = 0;
3259     info->out        = 0;
3260     info->err        = 0;
3261     info->fp         = Nullfp;
3262     info->useFILE    = 0;
3263     info->waiting    = 0;
3264     info->in_done    = TRUE;
3265     info->out_done   = TRUE;
3266     info->err_done   = TRUE;
3267     in[0] = out[0] = err[0] = '\0';
3268
3269     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3270         info->useFILE = 1;
3271         strcpy(p,p+1);
3272     }
3273     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3274         wait = 1;
3275         strcpy(p,p+1);
3276     }
3277
3278     if (*mode == 'r') {             /* piping from subroutine */
3279
3280         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3281         if (info->out) {
3282             info->out->pipe_done = &info->out_done;
3283             info->out_done = FALSE;
3284             info->out->info = info;
3285         }
3286         if (!info->useFILE) {
3287         info->fp  = PerlIO_open(mbx, mode);
3288         } else {
3289             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3290             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3291         }
3292
3293         if (!info->fp && info->out) {
3294             sys$cancel(info->out->chan_out);
3295
3296             while (!info->out_done) {
3297                 int done;
3298                 _ckvmssts(sys$setast(0));
3299                 done = info->out_done;
3300                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3301                 _ckvmssts(sys$setast(1));
3302                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3303             }
3304
3305             if (info->out->buf) {
3306                 n = info->out->bufsize * sizeof(char);
3307                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3308             }
3309             n = sizeof(Pipe);
3310             _ckvmssts(lib$free_vm(&n, &info->out));
3311             n = sizeof(Info);
3312             _ckvmssts(lib$free_vm(&n, &info));
3313             *psts = RMS$_FNF;
3314             return Nullfp;
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     } else if (*mode == 'w') {      /* piping to subroutine */
3325
3326         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3327         if (info->out) {
3328             info->out->pipe_done = &info->out_done;
3329             info->out_done = FALSE;
3330             info->out->info = info;
3331         }
3332
3333         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3334         if (info->err) {
3335             info->err->pipe_done = &info->err_done;
3336             info->err_done = FALSE;
3337             info->err->info = info;
3338         }
3339
3340         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3341         if (!info->useFILE) {
3342             info->fp  = PerlIO_open(mbx, mode);
3343         } else {
3344             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3345             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3346         }
3347
3348         if (info->in) {
3349             info->in->pipe_done = &info->in_done;
3350             info->in_done = FALSE;
3351             info->in->info = info;
3352         }
3353
3354         /* error cleanup */
3355         if (!info->fp && info->in) {
3356             info->done = TRUE;
3357             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3358                               0, 0, 0, 0, 0, 0, 0, 0));
3359
3360             while (!info->in_done) {
3361                 int done;
3362                 _ckvmssts(sys$setast(0));
3363                 done = info->in_done;
3364                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3365                 _ckvmssts(sys$setast(1));
3366                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3367             }
3368
3369             if (info->in->buf) {
3370                 n = info->in->bufsize * sizeof(char);
3371                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3372             }
3373             n = sizeof(Pipe);
3374             _ckvmssts(lib$free_vm(&n, &info->in));
3375             n = sizeof(Info);
3376             _ckvmssts(lib$free_vm(&n, &info));
3377             *psts = RMS$_FNF;
3378             return Nullfp;
3379         }
3380
3381
3382     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3383         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3384         if (info->out) {
3385             info->out->pipe_done = &info->out_done;
3386             info->out_done = FALSE;
3387             info->out->info = info;
3388         }
3389
3390         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3391         if (info->err) {
3392             info->err->pipe_done = &info->err_done;
3393             info->err_done = FALSE;
3394             info->err->info = info;
3395         }
3396     }
3397
3398     symbol[MAX_DCL_SYMBOL] = '\0';
3399
3400     strncpy(symbol, in, MAX_DCL_SYMBOL);
3401     d_symbol.dsc$w_length = strlen(symbol);
3402     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3403
3404     strncpy(symbol, err, MAX_DCL_SYMBOL);
3405     d_symbol.dsc$w_length = strlen(symbol);
3406     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3407
3408     strncpy(symbol, out, MAX_DCL_SYMBOL);
3409     d_symbol.dsc$w_length = strlen(symbol);
3410     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3411
3412     p = vmscmd->dsc$a_pointer;
3413     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3414     if (*p == '$') p++;                         /* remove leading $ */
3415     while (*p == ' ' || *p == '\t') p++;
3416
3417     for (j = 0; j < 4; j++) {
3418         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3419         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3420
3421     strncpy(symbol, p, MAX_DCL_SYMBOL);
3422     d_symbol.dsc$w_length = strlen(symbol);
3423     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3424
3425         if (strlen(p) > MAX_DCL_SYMBOL) {
3426             p += MAX_DCL_SYMBOL;
3427         } else {
3428             p += strlen(p);
3429         }
3430     }
3431     _ckvmssts(sys$setast(0));
3432     info->next=open_pipes;  /* prepend to list */
3433     open_pipes=info;
3434     _ckvmssts(sys$setast(1));
3435     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3436      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3437      * have SYS$COMMAND if we need it.
3438      */
3439     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3440                       0, &info->pid, &info->completion,
3441                       0, popen_completion_ast,info,0,0,0));
3442
3443     /* if we were using a tempfile, close it now */
3444
3445     if (tpipe) fclose(tpipe);
3446
3447     /* once the subprocess is spawned, it has copied the symbols and
3448        we can get rid of ours */
3449
3450     for (j = 0; j < 4; j++) {
3451         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3452         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3453     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3454     }
3455     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3456     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3457     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3458     vms_execfree(vmscmd);
3459
3460 #ifdef PERL_IMPLICIT_CONTEXT
3461     if (aTHX)
3462 #endif
3463     PL_forkprocess = info->pid;
3464
3465     if (wait) {
3466          int done = 0;
3467          while (!done) {
3468              _ckvmssts(sys$setast(0));
3469              done = info->done;
3470              if (!done) _ckvmssts(sys$clref(pipe_ef));
3471              _ckvmssts(sys$setast(1));
3472              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3473          }
3474         *psts = info->completion;
3475 /* Caller thinks it is open and tries to close it. */
3476 /* This causes some problems, as it changes the error status */
3477 /*        my_pclose(info->fp); */
3478     } else {
3479         *psts = SS$_NORMAL;
3480     }
3481     return info->fp;
3482 }  /* end of safe_popen */
3483
3484
3485 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3486 PerlIO *
3487 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3488 {
3489     int sts;
3490     TAINT_ENV();
3491     TAINT_PROPER("popen");
3492     PERL_FLUSHALL_FOR_CHILD;
3493     return safe_popen(aTHX_ cmd,mode,&sts);
3494 }
3495
3496 /*}}}*/
3497
3498 /*{{{  I32 my_pclose(PerlIO *fp)*/
3499 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3500 {
3501     pInfo info, last = NULL;
3502     unsigned long int retsts;
3503     int done, iss, n;
3504
3505     for (info = open_pipes; info != NULL; last = info, info = info->next)
3506         if (info->fp == fp) break;
3507
3508     if (info == NULL) {  /* no such pipe open */
3509       set_errno(ECHILD); /* quoth POSIX */
3510       set_vaxc_errno(SS$_NONEXPR);
3511       return -1;
3512     }
3513
3514     /* If we were writing to a subprocess, insure that someone reading from
3515      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3516      * produce an EOF record in the mailbox.
3517      *
3518      *  well, at least sometimes it *does*, so we have to watch out for
3519      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3520      */
3521      if (info->fp) {
3522         if (!info->useFILE)
3523             PerlIO_flush(info->fp);   /* first, flush data */
3524         else
3525             fflush((FILE *)info->fp);
3526     }
3527
3528     _ckvmssts(sys$setast(0));
3529      info->closing = TRUE;
3530      done = info->done && info->in_done && info->out_done && info->err_done;
3531      /* hanging on write to Perl's input? cancel it */
3532      if (info->mode == 'r' && info->out && !info->out_done) {
3533         if (info->out->chan_out) {
3534             _ckvmssts(sys$cancel(info->out->chan_out));
3535             if (!info->out->chan_in) {   /* EOF generation, need AST */
3536                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3537             }
3538         }
3539      }
3540      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3541          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3542                            0, 0, 0, 0, 0, 0));
3543     _ckvmssts(sys$setast(1));
3544     if (info->fp) {
3545      if (!info->useFILE)
3546         PerlIO_close(info->fp);
3547      else
3548         fclose((FILE *)info->fp);
3549     }
3550      /*
3551         we have to wait until subprocess completes, but ALSO wait until all
3552         the i/o completes...otherwise we'll be freeing the "info" structure
3553         that the i/o ASTs could still be using...
3554      */
3555
3556      while (!done) {
3557          _ckvmssts(sys$setast(0));
3558          done = info->done && info->in_done && info->out_done && info->err_done;
3559          if (!done) _ckvmssts(sys$clref(pipe_ef));
3560          _ckvmssts(sys$setast(1));
3561          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3562      }
3563      retsts = info->completion;
3564
3565     /* remove from list of open pipes */
3566     _ckvmssts(sys$setast(0));
3567     if (last) last->next = info->next;
3568     else open_pipes = info->next;
3569     _ckvmssts(sys$setast(1));
3570
3571     /* free buffers and structures */
3572
3573     if (info->in) {
3574         if (info->in->buf) {
3575             n = info->in->bufsize * sizeof(char);
3576             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3577         }
3578         n = sizeof(Pipe);
3579         _ckvmssts(lib$free_vm(&n, &info->in));
3580     }
3581     if (info->out) {
3582         if (info->out->buf) {
3583             n = info->out->bufsize * sizeof(char);
3584             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3585         }
3586         n = sizeof(Pipe);
3587         _ckvmssts(lib$free_vm(&n, &info->out));
3588     }
3589     if (info->err) {
3590         if (info->err->buf) {
3591             n = info->err->bufsize * sizeof(char);
3592             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3593         }
3594         n = sizeof(Pipe);
3595         _ckvmssts(lib$free_vm(&n, &info->err));
3596     }
3597     n = sizeof(Info);
3598     _ckvmssts(lib$free_vm(&n, &info));
3599
3600     return retsts;
3601
3602 }  /* end of my_pclose() */
3603
3604 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3605   /* Roll our own prototype because we want this regardless of whether
3606    * _VMS_WAIT is defined.
3607    */
3608   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3609 #endif
3610 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3611    created with popen(); otherwise partially emulate waitpid() unless
3612    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3613    Also check processes not considered by the CRTL waitpid().
3614  */
3615 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3616 Pid_t
3617 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3618 {
3619     pInfo info;
3620     int done;
3621     int sts;
3622     int j;
3623
3624     if (statusp) *statusp = 0;
3625
3626     for (info = open_pipes; info != NULL; info = info->next)
3627         if (info->pid == pid) break;
3628
3629     if (info != NULL) {  /* we know about this child */
3630       while (!info->done) {
3631           _ckvmssts(sys$setast(0));
3632           done = info->done;
3633           if (!done) _ckvmssts(sys$clref(pipe_ef));
3634           _ckvmssts(sys$setast(1));
3635           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3636       }
3637
3638       if (statusp) *statusp = info->completion;
3639       return pid;
3640     }
3641
3642     /* child that already terminated? */
3643
3644     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3645         if (closed_list[j].pid == pid) {
3646             if (statusp) *statusp = closed_list[j].completion;
3647             return pid;
3648         }
3649     }
3650
3651     /* fall through if this child is not one of our own pipe children */
3652
3653 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3654
3655       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3656        * in 7.2 did we get a version that fills in the VMS completion
3657        * status as Perl has always tried to do.
3658        */
3659
3660       sts = __vms_waitpid( pid, statusp, flags );
3661
3662       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3663          return sts;
3664
3665       /* If the real waitpid tells us the child does not exist, we
3666        * fall through here to implement waiting for a child that
3667        * was created by some means other than exec() (say, spawned
3668        * from DCL) or to wait for a process that is not a subprocess
3669        * of the current process.
3670        */
3671
3672 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3673
3674     {
3675       $DESCRIPTOR(intdsc,"0 00:00:01");
3676       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3677       unsigned long int pidcode = JPI$_PID, mypid;
3678       unsigned long int interval[2];
3679       unsigned int jpi_iosb[2];
3680       struct itmlst_3 jpilist[2] = {
3681           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3682           {                      0,         0,                 0, 0}
3683       };
3684
3685       if (pid <= 0) {
3686         /* Sorry folks, we don't presently implement rooting around for
3687            the first child we can find, and we definitely don't want to
3688            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3689          */
3690         set_errno(ENOTSUP);
3691         return -1;
3692       }
3693
3694       /* Get the owner of the child so I can warn if it's not mine. If the
3695        * process doesn't exist or I don't have the privs to look at it,
3696        * I can go home early.
3697        */
3698       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3699       if (sts & 1) sts = jpi_iosb[0];
3700       if (!(sts & 1)) {
3701         switch (sts) {
3702             case SS$_NONEXPR:
3703                 set_errno(ECHILD);
3704                 break;
3705             case SS$_NOPRIV:
3706                 set_errno(EACCES);
3707                 break;
3708             default:
3709                 _ckvmssts(sts);
3710         }
3711         set_vaxc_errno(sts);
3712         return -1;
3713       }
3714
3715       if (ckWARN(WARN_EXEC)) {
3716         /* remind folks they are asking for non-standard waitpid behavior */
3717         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3718         if (ownerpid != mypid)
3719           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3720                       "waitpid: process %x is not a child of process %x",
3721                       pid,mypid);
3722       }
3723
3724       /* simply check on it once a second until it's not there anymore. */
3725
3726       _ckvmssts(sys$bintim(&intdsc,interval));
3727       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3728             _ckvmssts(sys$schdwk(0,0,interval,0));
3729             _ckvmssts(sys$hiber());
3730       }
3731       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3732
3733       _ckvmssts(sts);
3734       return pid;
3735     }
3736 }  /* end of waitpid() */
3737 /*}}}*/
3738 /*}}}*/
3739 /*}}}*/
3740
3741 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3742 char *
3743 my_gconvert(double val, int ndig, int trail, char *buf)
3744 {
3745   static char __gcvtbuf[DBL_DIG+1];
3746   char *loc;
3747
3748   loc = buf ? buf : __gcvtbuf;
3749
3750 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3751   if (val < 1) {
3752     sprintf(loc,"%.*g",ndig,val);
3753     return loc;
3754   }
3755 #endif
3756
3757   if (val) {
3758     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3759     return gcvt(val,ndig,loc);
3760   }
3761   else {
3762     loc[0] = '0'; loc[1] = '\0';
3763     return loc;
3764   }
3765
3766 }
3767 /*}}}*/
3768
3769 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3770 static int rms_free_search_context(struct FAB * fab)
3771 {
3772 struct NAM * nam;
3773
3774     nam = fab->fab$l_nam;
3775     nam->nam$b_nop |= NAM$M_SYNCHK;
3776     nam->nam$l_rlf = NULL;
3777     fab->fab$b_dns = 0;
3778     return sys$parse(fab, NULL, NULL);
3779 }
3780
3781 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3782 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3783 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3784 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3785 #define rms_nam_esll(nam) nam.nam$b_esl
3786 #define rms_nam_esl(nam) nam.nam$b_esl
3787 #define rms_nam_name(nam) nam.nam$l_name
3788 #define rms_nam_namel(nam) nam.nam$l_name
3789 #define rms_nam_type(nam) nam.nam$l_type
3790 #define rms_nam_typel(nam) nam.nam$l_type
3791 #define rms_nam_ver(nam) nam.nam$l_ver
3792 #define rms_nam_verl(nam) nam.nam$l_ver
3793 #define rms_nam_rsll(nam) nam.nam$b_rsl
3794 #define rms_nam_rsl(nam) nam.nam$b_rsl
3795 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3796 #define rms_set_fna(fab, nam, name, size) \
3797         fab.fab$b_fns = size; fab.fab$l_fna = name;
3798 #define rms_get_fna(fab, nam) fab.fab$l_fna
3799 #define rms_set_dna(fab, nam, name, size) \
3800         fab.fab$b_dns = size; fab.fab$l_dna = name;
3801 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3802 #define rms_set_esa(fab, nam, name, size) \
3803         nam.nam$b_ess = size; nam.nam$l_esa = name;
3804 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3805         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3806 #define rms_set_rsa(nam, name, size) \
3807         nam.nam$l_rsa = name; nam.nam$b_rss = size;
3808 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3809         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3810
3811 #else
3812 static int rms_free_search_context(struct FAB * fab)
3813 {
3814 struct NAML * nam;
3815
3816     nam = fab->fab$l_naml;
3817     nam->naml$b_nop |= NAM$M_SYNCHK;
3818     nam->naml$l_rlf = NULL;
3819     nam->naml$l_long_defname_size = 0;
3820     fab->fab$b_dns = 0;
3821     return sys$parse(fab, NULL, NULL);
3822 }
3823
3824 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3825 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3826 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3827 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3828 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3829 #define rms_nam_esl(nam) nam.naml$b_esl
3830 #define rms_nam_name(nam) nam.naml$l_name
3831 #define rms_nam_namel(nam) nam.naml$l_long_name
3832 #define rms_nam_type(nam) nam.naml$l_type
3833 #define rms_nam_typel(nam) nam.naml$l_long_type
3834 #define rms_nam_ver(nam) nam.naml$l_ver
3835 #define rms_nam_verl(nam) nam.naml$l_long_ver
3836 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3837 #define rms_nam_rsl(nam) nam.naml$b_rsl
3838 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3839 #define rms_set_fna(fab, nam, name, size) \
3840         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3841         nam.naml$l_long_filename_size = size; \
3842         nam.naml$l_long_filename = name
3843 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3844 #define rms_set_dna(fab, nam, name, size) \
3845         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3846         nam.naml$l_long_defname_size = size; \
3847         nam.naml$l_long_defname = name
3848 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3849 #define rms_set_esa(fab, nam, name, size) \
3850         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3851         nam.naml$l_long_expand_alloc = size; \
3852         nam.naml$l_long_expand = name
3853 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3854         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3855         nam.naml$l_long_expand = l_name; \
3856         nam.naml$l_long_expand_alloc = l_size;
3857 #define rms_set_rsa(nam, name, size) \
3858         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3859         nam.naml$l_long_result = name; \
3860         nam.naml$l_long_result_alloc = size;
3861 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3862         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3863         nam.naml$l_long_result = l_name; \
3864         nam.naml$l_long_result_alloc = l_size;
3865
3866 #endif
3867
3868
3869 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3870 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3871  * to expand file specification.  Allows for a single default file
3872  * specification and a simple mask of options.  If outbuf is non-NULL,
3873  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3874  * the resultant file specification is placed.  If outbuf is NULL, the
3875  * resultant file specification is placed into a static buffer.
3876  * The third argument, if non-NULL, is taken to be a default file
3877  * specification string.  The fourth argument is unused at present.
3878  * rmesexpand() returns the address of the resultant string if
3879  * successful, and NULL on error.
3880  *
3881  * New functionality for previously unused opts value:
3882  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3883  */
3884 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3885
3886 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3887 /* ODS-2 only version */
3888 static char *
3889 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3890 {
3891   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3892   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3893   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3894   struct FAB myfab = cc$rms_fab;
3895   struct NAM mynam = cc$rms_nam;
3896   STRLEN speclen;
3897   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3898   int sts;
3899
3900   if (!filespec || !*filespec) {
3901     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3902     return NULL;
3903   }
3904   if (!outbuf) {
3905     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3906     else    outbuf = __rmsexpand_retbuf;
3907   }
3908   isunix = is_unix_filespec(filespec);
3909   if (isunix) {
3910     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3911         if (out)
3912            Safefree(out);
3913         return NULL;
3914     }
3915     filespec = vmsfspec;
3916   }
3917
3918   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3919   myfab.fab$b_fns = strlen(filespec);
3920   myfab.fab$l_nam = &mynam;
3921
3922   if (defspec && *defspec) {
3923     if (strchr(defspec,'/') != NULL) {
3924       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3925         if (out)
3926            Safefree(out);
3927         return NULL;
3928       }
3929       defspec = tmpfspec;
3930     }
3931     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3932     myfab.fab$b_dns = strlen(defspec);
3933   }
3934
3935   mynam.nam$l_esa = esa;
3936   mynam.nam$b_ess = sizeof esa;
3937   mynam.nam$l_rsa = outbuf;
3938   mynam.nam$b_rss = NAM$C_MAXRSS;
3939
3940 #ifdef NAM$M_NO_SHORT_UPCASE
3941   if (decc_efs_case_preserve)
3942     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3943 #endif
3944
3945   retsts = sys$parse(&myfab,0,0);
3946   if (!(retsts & 1)) {
3947     mynam.nam$b_nop |= NAM$M_SYNCHK;
3948     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3949       retsts = sys$parse(&myfab,0,0);
3950       if (retsts & 1) goto expanded;
3951     }
3952     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3953     sts = sys$parse(&myfab,0,0);  /* Free search context */
3954     if (out) Safefree(out);
3955     set_vaxc_errno(retsts);
3956     if      (retsts == RMS$_PRV) set_errno(EACCES);
3957     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3958     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3959     else                         set_errno(EVMSERR);
3960     return NULL;
3961   }
3962   retsts = sys$search(&myfab,0,0);
3963   if (!(retsts & 1) && retsts != RMS$_FNF) {
3964     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3965     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3966     if (out) Safefree(out);
3967     set_vaxc_errno(retsts);
3968     if      (retsts == RMS$_PRV) set_errno(EACCES);
3969     else                         set_errno(EVMSERR);
3970     return NULL;
3971   }
3972
3973   /* If the input filespec contained any lowercase characters,
3974    * downcase the result for compatibility with Unix-minded code. */
3975   expanded:
3976   if (!decc_efs_case_preserve) {
3977     for (out = myfab.fab$l_fna; *out; out++)
3978       if (islower(*out)) { haslower = 1; break; }
3979   }
3980   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3981   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3982   /* Trim off null fields added by $PARSE
3983    * If type > 1 char, must have been specified in original or default spec
3984    * (not true for version; $SEARCH may have added version of existing file).
3985    */
3986   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3987   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3988              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3989   if (trimver || trimtype) {
3990     if (defspec && *defspec) {
3991       char defesa[NAM$C_MAXRSS];
3992       struct FAB deffab = cc$rms_fab;
3993       struct NAM defnam = cc$rms_nam;
3994
3995       deffab.fab$l_nam = &defnam;
3996       /* cast below ok for read only pointer */
3997       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3998       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3999       defnam.nam$b_nop = NAM$M_SYNCHK;
4000 #ifdef NAM$M_NO_SHORT_UPCASE
4001       if (decc_efs_case_preserve)
4002         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4003 #endif
4004       if (sys$parse(&deffab,0,0) & 1) {
4005         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4006         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4007       }
4008     }
4009     if (trimver) {
4010       if (*mynam.nam$l_ver != '\"')
4011         speclen = mynam.nam$l_ver - out;
4012     }
4013     if (trimtype) {
4014       /* If we didn't already trim version, copy down */
4015       if (speclen > mynam.nam$l_ver - out)
4016         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4017                speclen - (mynam.nam$l_ver - out));
4018       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4019     }
4020   }
4021   /* If we just had a directory spec on input, $PARSE "helpfully"
4022    * adds an empty name and type for us */
4023   if (mynam.nam$l_name == mynam.nam$l_type &&
4024       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4025       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4026     speclen = mynam.nam$l_name - out;
4027
4028   /* Posix format specifications must have matching quotes */
4029   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4030     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4031       out[speclen] = '\"';
4032       speclen++;
4033     }
4034   }
4035
4036   out[speclen] = '\0';
4037   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4038
4039   /* Have we been working with an expanded, but not resultant, spec? */
4040   /* Also, convert back to Unix syntax if necessary. */
4041   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4042     isunix = 0;
4043
4044   if (!mynam.nam$b_rsl) {
4045     if (isunix) {
4046       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4047     }
4048     else strcpy(outbuf,esa);
4049   }
4050   else if (isunix) {
4051     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4052     strcpy(outbuf,tmpfspec);
4053   }
4054   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4055   mynam.nam$l_rsa = NULL;
4056   mynam.nam$b_rss = 0;
4057   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4058   return outbuf;
4059 }
4060 #else
4061 /* ODS-5 supporting routine */
4062 static char *
4063 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4064 {
4065   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4066   char * vmsfspec, *tmpfspec;
4067   char * esa, *cp, *out = NULL;
4068   char * esal;
4069   char * outbufl;
4070   struct FAB myfab = cc$rms_fab;
4071   rms_setup_nam(mynam);
4072   STRLEN speclen;
4073   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4074   int sts;
4075
4076   if (!filespec || !*filespec) {
4077     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4078     return NULL;
4079   }
4080   if (!outbuf) {
4081     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4082     else    outbuf = __rmsexpand_retbuf;
4083   }
4084
4085   vmsfspec = NULL;
4086   tmpfspec = NULL;
4087   outbufl = NULL;
4088   isunix = is_unix_filespec(filespec);
4089   if (isunix) {
4090     Newx(vmsfspec, VMS_MAXRSS, char);
4091     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4092         Safefree(vmsfspec);
4093         if (out)
4094            Safefree(out);
4095         return NULL;
4096     }
4097     filespec = vmsfspec;
4098
4099      /* Unless we are forcing to VMS format, a UNIX input means
4100       * UNIX output, and that requires long names to be used
4101       */
4102     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4103         opts |= PERL_RMSEXPAND_M_LONG;
4104     else {
4105         isunix = 0;
4106     }
4107   }
4108
4109   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4110   rms_bind_fab_nam(myfab, mynam);
4111
4112   if (defspec && *defspec) {
4113     int t_isunix;
4114     t_isunix = is_unix_filespec(defspec);
4115     if (t_isunix) {
4116       Newx(tmpfspec, VMS_MAXRSS, char);
4117       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4118         Safefree(tmpfspec);
4119         if (vmsfspec != NULL)
4120             Safefree(vmsfspec);
4121         if (out)
4122            Safefree(out);
4123         return NULL;
4124       }
4125       defspec = tmpfspec;
4126     }
4127     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4128   }
4129
4130   Newx(esa, NAM$C_MAXRSS + 1, char);
4131 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4132   Newx(esal, NAML$C_MAXRSS + 1, char);
4133 #endif
4134   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4135
4136   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4137     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4138   }
4139   else {
4140 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4141     Newx(outbufl, VMS_MAXRSS, char);
4142     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4143 #else
4144     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4145 #endif
4146   }
4147
4148 #ifdef NAM$M_NO_SHORT_UPCASE
4149   if (decc_efs_case_preserve)
4150     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4151 #endif
4152
4153   /* First attempt to parse as an existing file */
4154   retsts = sys$parse(&myfab,0,0);
4155   if (!(retsts & STS$K_SUCCESS)) {
4156
4157     /* Could not find the file, try as syntax only if error is not fatal */
4158     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4159     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4160       retsts = sys$parse(&myfab,0,0);
4161       if (retsts & STS$K_SUCCESS) goto expanded;
4162     }
4163
4164      /* Still could not parse the file specification */
4165     /*----------------------------------------------*/
4166     sts = rms_free_search_context(&myfab); /* Free search context */
4167     if (out) Safefree(out);
4168     if (tmpfspec != NULL)
4169         Safefree(tmpfspec);
4170     if (vmsfspec != NULL)
4171         Safefree(vmsfspec);
4172     Safefree(esa);
4173     Safefree(esal);
4174     set_vaxc_errno(retsts);
4175     if      (retsts == RMS$_PRV) set_errno(EACCES);
4176     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4177     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4178     else                         set_errno(EVMSERR);
4179     return NULL;
4180   }
4181   retsts = sys$search(&myfab,0,0);
4182   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4183     sts = rms_free_search_context(&myfab); /* Free search context */
4184     if (out) Safefree(out);
4185     if (tmpfspec != NULL)
4186         Safefree(tmpfspec);
4187     if (vmsfspec != NULL)
4188         Safefree(vmsfspec);
4189     Safefree(esa);
4190     Safefree(esal);
4191     set_vaxc_errno(retsts);
4192     if      (retsts == RMS$_PRV) set_errno(EACCES);
4193     else                         set_errno(EVMSERR);
4194     return NULL;
4195   }
4196
4197   /* If the input filespec contained any lowercase characters,
4198    * downcase the result for compatibility with Unix-minded code. */
4199   expanded:
4200   if (!decc_efs_case_preserve) {
4201     for (out = rms_get_fna(myfab, mynam); *out; out++)
4202       if (islower(*out)) { haslower = 1; break; }
4203   }
4204
4205    /* Is a long or a short name expected */
4206   /*------------------------------------*/
4207   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4208     if (rms_nam_rsll(mynam)) {
4209         out = outbuf;
4210         speclen = rms_nam_rsll(mynam);
4211     }
4212     else {
4213         out = esal; /* Not esa */
4214         speclen = rms_nam_esll(mynam);
4215     }
4216   }
4217   else {
4218     if (rms_nam_rsl(mynam)) {
4219         out = outbuf;
4220         speclen = rms_nam_rsl(mynam);
4221     }
4222     else {
4223         out = esa; /* Not esal */
4224         speclen = rms_nam_esl(mynam);
4225     }
4226   }
4227   /* Trim off null fields added by $PARSE
4228    * If type > 1 char, must have been specified in original or default spec
4229    * (not true for version; $SEARCH may have added version of existing file).
4230    */
4231   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4232   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4233     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4234              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4235   }
4236   else {
4237     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4238              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4239   }
4240   if (trimver || trimtype) {
4241     if (defspec && *defspec) {
4242       char *defesal = NULL;
4243       Newx(defesal, NAML$C_MAXRSS + 1, char);
4244       if (defesal != NULL) {
4245         struct FAB deffab = cc$rms_fab;
4246         rms_setup_nam(defnam);
4247
4248         rms_bind_fab_nam(deffab, defnam);
4249
4250         /* Cast ok */
4251         rms_set_fna
4252             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4253
4254         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4255
4256         rms_set_nam_nop(defnam, 0);
4257         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4258 #ifdef NAM$M_NO_SHORT_UPCASE
4259         if (decc_efs_case_preserve)
4260           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4261 #endif
4262         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4263           if (trimver) {
4264              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4265           }
4266           if (trimtype) {
4267             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4268           }
4269         }
4270         Safefree(defesal);
4271       }
4272     }
4273     if (trimver) {
4274       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4275         if (*(rms_nam_verl(mynam)) != '\"')
4276           speclen = rms_nam_verl(mynam) - out;
4277       }
4278       else {
4279         if (*(rms_nam_ver(mynam)) != '\"')
4280           speclen = rms_nam_ver(mynam) - out;
4281       }
4282     }
4283     if (trimtype) {
4284       /* If we didn't already trim version, copy down */
4285       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4286         if (speclen > rms_nam_verl(mynam) - out)
4287           memmove
4288            (rms_nam_typel(mynam),
4289             rms_nam_verl(mynam),
4290             speclen - (rms_nam_verl(mynam) - out));
4291           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4292       }
4293       else {
4294         if (speclen > rms_nam_ver(mynam) - out)
4295           memmove
4296            (rms_nam_type(mynam),
4297             rms_nam_ver(mynam),
4298             speclen - (rms_nam_ver(mynam) - out));
4299           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4300       }
4301     }
4302   }
4303
4304    /* Done with these copies of the input files */
4305   /*-------------------------------------------*/
4306   if (vmsfspec != NULL)
4307         Safefree(vmsfspec);
4308   if (tmpfspec != NULL)
4309         Safefree(tmpfspec);
4310
4311   /* If we just had a directory spec on input, $PARSE "helpfully"
4312    * adds an empty name and type for us */
4313   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4314     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4315         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4316         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4317       speclen = rms_nam_namel(mynam) - out;
4318   }
4319   else {
4320     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4321         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4322         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4323       speclen = rms_nam_name(mynam) - out;
4324   }
4325
4326   /* Posix format specifications must have matching quotes */
4327   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4328     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4329       out[speclen] = '\"';
4330       speclen++;
4331     }
4332   }
4333   out[speclen] = '\0';
4334   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4335
4336   /* Have we been working with an expanded, but not resultant, spec? */
4337   /* Also, convert back to Unix syntax if necessary. */
4338
4339   if (!rms_nam_rsll(mynam)) {
4340     if (isunix) {
4341       if (do_tounixspec(esa,outbuf,0) == NULL) {
4342         Safefree(esal);
4343         Safefree(esa);
4344         return NULL;
4345       }
4346     }
4347     else strcpy(outbuf,esa);
4348   }
4349   else if (isunix) {
4350     Newx(tmpfspec, VMS_MAXRSS, char);
4351     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4352         Safefree(esa);
4353         Safefree(esal);
4354         Safefree(tmpfspec);
4355         return NULL;
4356     }
4357     strcpy(outbuf,tmpfspec);
4358     Safefree(tmpfspec);
4359   }
4360
4361   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4362   sts = rms_free_search_context(&myfab); /* Free search context */
4363   Safefree(esa);
4364   Safefree(esal);
4365   return outbuf;
4366 }
4367 #endif
4368 /*}}}*/
4369 /* External entry points */
4370 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4371 { return do_rmsexpand(spec,buf,0,def,opt); }
4372 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4373 { return do_rmsexpand(spec,buf,1,def,opt); }
4374
4375
4376 /*
4377 ** The following routines are provided to make life easier when
4378 ** converting among VMS-style and Unix-style directory specifications.
4379 ** All will take input specifications in either VMS or Unix syntax. On
4380 ** failure, all return NULL.  If successful, the routines listed below
4381 ** return a pointer to a buffer containing the appropriately
4382 ** reformatted spec (and, therefore, subsequent calls to that routine
4383 ** will clobber the result), while the routines of the same names with
4384 ** a _ts suffix appended will return a pointer to a mallocd string
4385 ** containing the appropriately reformatted spec.
4386 ** In all cases, only explicit syntax is altered; no check is made that
4387 ** the resulting string is valid or that the directory in question
4388 ** actually exists.
4389 **
4390 **   fileify_dirspec() - convert a directory spec into the name of the
4391 **     directory file (i.e. what you can stat() to see if it's a dir).
4392 **     The style (VMS or Unix) of the result is the same as the style
4393 **     of the parameter passed in.
4394 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4395 **     what you prepend to a filename to indicate what directory it's in).
4396 **     The style (VMS or Unix) of the result is the same as the style
4397 **     of the parameter passed in.
4398 **   tounixpath() - convert a directory spec into a Unix-style path.
4399 **   tovmspath() - convert a directory spec into a VMS-style path.
4400 **   tounixspec() - convert any file spec into a Unix-style file spec.
4401 **   tovmsspec() - convert any file spec into a VMS-style spec.
4402 **
4403 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4404 ** Permission is given to distribute this code as part of the Perl
4405 ** standard distribution under the terms of the GNU General Public
4406 ** License or the Perl Artistic License.  Copies of each may be
4407 ** found in the Perl standard distribution.
4408  */
4409
4410 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4411 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4412 {
4413     static char __fileify_retbuf[VMS_MAXRSS];
4414     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4415     char *retspec, *cp1, *cp2, *lastdir;
4416     char *trndir, *vmsdir;
4417     unsigned short int trnlnm_iter_count;
4418     int sts;
4419
4420     if (!dir || !*dir) {
4421       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4422     }
4423     dirlen = strlen(dir);
4424     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4425     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4426       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4427         dir = "/sys$disk";
4428         dirlen = 9;
4429       }
4430       else
4431         dirlen = 1;
4432     }
4433     if (dirlen > (VMS_MAXRSS - 1)) {
4434       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4435       return NULL;
4436     }
4437     Newx(trndir, VMS_MAXRSS + 1, char);
4438     if (!strpbrk(dir+1,"/]>:")  &&
4439         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4440       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4441       trnlnm_iter_count = 0;
4442       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4443         trnlnm_iter_count++;
4444         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4445       }
4446       dirlen = strlen(trndir);
4447     }
4448     else {
4449       strncpy(trndir,dir,dirlen);
4450       trndir[dirlen] = '\0';
4451     }
4452
4453     /* At this point we are done with *dir and use *trndir which is a
4454      * copy that can be modified.  *dir must not be modified.
4455      */
4456
4457     /* If we were handed a rooted logical name or spec, treat it like a
4458      * simple directory, so that
4459      *    $ Define myroot dev:[dir.]
4460      *    ... do_fileify_dirspec("myroot",buf,1) ...
4461      * does something useful.
4462      */
4463     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4464       trndir[--dirlen] = '\0';
4465       trndir[dirlen-1] = ']';
4466     }
4467     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4468       trndir[--dirlen] = '\0';
4469       trndir[dirlen-1] = '>';
4470     }
4471
4472     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4473       /* If we've got an explicit filename, we can just shuffle the string. */
4474       if (*(cp1+1)) hasfilename = 1;
4475       /* Similarly, we can just back up a level if we've got multiple levels
4476          of explicit directories in a VMS spec which ends with directories. */
4477       else {
4478         for (cp2 = cp1; cp2 > trndir; cp2--) {
4479           if (*cp2 == '.') {
4480             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4481               *cp2 = *cp1; *cp1 = '\0';
4482               hasfilename = 1;
4483               break;
4484             }
4485           }
4486           if (*cp2 == '[' || *cp2 == '<') break;
4487         }
4488       }
4489     }
4490
4491     Newx(vmsdir, VMS_MAXRSS + 1, char);
4492     cp1 = strpbrk(trndir,"]:>");
4493     if (hasfilename || !cp1) { /* Unix-style path or filename */
4494       if (trndir[0] == '.') {
4495         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4496           Safefree(trndir);
4497           Safefree(vmsdir);
4498           return do_fileify_dirspec("[]",buf,ts);
4499         }
4500         else if (trndir[1] == '.' &&
4501                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4502           Safefree(trndir);
4503           Safefree(vmsdir);
4504           return do_fileify_dirspec("[-]",buf,ts);
4505         }
4506       }
4507       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4508         dirlen -= 1;                 /* to last element */
4509         lastdir = strrchr(trndir,'/');
4510       }
4511       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4512         /* If we have "/." or "/..", VMSify it and let the VMS code
4513          * below expand it, rather than repeating the code to handle
4514          * relative components of a filespec here */
4515         do {
4516           if (*(cp1+2) == '.') cp1++;
4517           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4518             char * ret_chr;
4519             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4520                 Safefree(trndir);
4521                 Safefree(vmsdir);
4522                 return NULL;
4523             }
4524             if (strchr(vmsdir,'/') != NULL) {
4525               /* If do_tovmsspec() returned it, it must have VMS syntax
4526                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4527                * the time to check this here only so we avoid a recursion
4528                * loop; otherwise, gigo.
4529                */
4530               Safefree(trndir);
4531               Safefree(vmsdir);
4532               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4533               return NULL;
4534             }
4535             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4536                 Safefree(trndir);
4537                 Safefree(vmsdir);
4538                 return NULL;
4539             }
4540             ret_chr = do_tounixspec(trndir,buf,ts);
4541             Safefree(trndir);
4542             Safefree(vmsdir);
4543             return ret_chr;
4544           }
4545           cp1++;
4546         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4547         lastdir = strrchr(trndir,'/');
4548       }
4549       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4550         char * ret_chr;
4551         /* Ditto for specs that end in an MFD -- let the VMS code
4552          * figure out whether it's a real device or a rooted logical. */
4553
4554         /* This should not happen any more.  Allowing the fake /000000
4555          * in a UNIX pathname causes all sorts of problems when trying
4556          * to run in UNIX emulation.  So the VMS to UNIX conversions
4557          * now remove the fake /000000 directories.
4558          */
4559
4560         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4561         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4562             Safefree(trndir);
4563             Safefree(vmsdir);
4564             return NULL;
4565         }
4566         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4567             Safefree(trndir);
4568             Safefree(vmsdir);
4569             return NULL;
4570         }
4571         ret_chr = do_tounixspec(trndir,buf,ts);
4572         Safefree(trndir);
4573         Safefree(vmsdir);
4574         return ret_chr;
4575       }
4576       else {
4577
4578         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4579              !(lastdir = cp1 = strrchr(trndir,']')) &&
4580              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4581         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4582           int ver; char *cp3;
4583
4584           /* For EFS or ODS-5 look for the last dot */
4585           if (decc_efs_charset) {
4586               cp2 = strrchr(cp1,'.');
4587           }
4588           if (vms_process_case_tolerant) {
4589               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4590                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4591                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4592                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4593                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4594                             (ver || *cp3)))))) {
4595                   Safefree(trndir);
4596                   Safefree(vmsdir);
4597                   set_errno(ENOTDIR);
4598                   set_vaxc_errno(RMS$_DIR);
4599                   return NULL;
4600               }
4601           }
4602           else {
4603               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4604                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4605                   !*(cp2+3) || *(cp2+3) != 'R' ||
4606                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4607                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4608                             (ver || *cp3)))))) {
4609                  Safefree(trndir);
4610                  Safefree(vmsdir);
4611                  set_errno(ENOTDIR);
4612                  set_vaxc_errno(RMS$_DIR);
4613                  return NULL;
4614               }
4615           }
4616           dirlen = cp2 - trndir;
4617         }
4618       }
4619
4620       retlen = dirlen + 6;
4621       if (buf) retspec = buf;
4622       else if (ts) Newx(retspec,retlen+1,char);
4623       else retspec = __fileify_retbuf;
4624       memcpy(retspec,trndir,dirlen);
4625       retspec[dirlen] = '\0';
4626
4627       /* We've picked up everything up to the directory file name.
4628          Now just add the type and version, and we're set. */
4629       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4630         strcat(retspec,".dir;1");
4631       else
4632         strcat(retspec,".DIR;1");
4633       Safefree(trndir);
4634       Safefree(vmsdir);
4635       return retspec;
4636     }
4637     else {  /* VMS-style directory spec */
4638
4639       char *esa, term, *cp;
4640       unsigned long int sts, cmplen, haslower = 0;
4641       unsigned int nam_fnb;
4642       char * nam_type;
4643       struct FAB dirfab = cc$rms_fab;
4644       rms_setup_nam(savnam);
4645       rms_setup_nam(dirnam);
4646
4647       Newx(esa, VMS_MAXRSS + 1, char);
4648       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4649       rms_bind_fab_nam(dirfab, dirnam);
4650       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4651       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4652 #ifdef NAM$M_NO_SHORT_UPCASE
4653       if (decc_efs_case_preserve)
4654         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4655 #endif
4656
4657       for (cp = trndir; *cp; cp++)
4658         if (islower(*cp)) { haslower = 1; break; }
4659       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4660         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4661           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4662           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4663         }
4664         if (!sts) {
4665           Safefree(esa);
4666           Safefree(trndir);
4667           Safefree(vmsdir);
4668           set_errno(EVMSERR);
4669           set_vaxc_errno(dirfab.fab$l_sts);
4670           return NULL;
4671         }
4672       }
4673       else {
4674         savnam = dirnam;
4675         /* Does the file really exist? */
4676         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4677           /* Yes; fake the fnb bits so we'll check type below */
4678         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4679         }
4680         else { /* No; just work with potential name */
4681           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4682           else {
4683             Safefree(esa);
4684             Safefree(trndir);
4685             Safefree(vmsdir);
4686             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4687             sts = rms_free_search_context(&dirfab);
4688             return NULL;
4689           }
4690         }
4691       }
4692       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4693         cp1 = strchr(esa,']');
4694         if (!cp1) cp1 = strchr(esa,'>');
4695         if (cp1) {  /* Should always be true */
4696           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4697           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4698         }
4699       }
4700       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4701         /* Yep; check version while we're at it, if it's there. */
4702         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4703         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4704           /* Something other than .DIR[;1].  Bzzt. */
4705           sts = rms_free_search_context(&dirfab);
4706           Safefree(esa);
4707           Safefree(trndir);
4708           Safefree(vmsdir);
4709           set_errno(ENOTDIR);
4710           set_vaxc_errno(RMS$_DIR);
4711           return NULL;
4712         }
4713       }
4714       esa[rms_nam_esll(dirnam)] = '\0';
4715       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4716         /* They provided at least the name; we added the type, if necessary, */
4717         if (buf) retspec = buf;                            /* in sys$parse() */
4718         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4719         else retspec = __fileify_retbuf;
4720         strcpy(retspec,esa);
4721         sts = rms_free_search_context(&dirfab);
4722         Safefree(trndir);
4723         Safefree(esa);
4724         Safefree(vmsdir);
4725         return retspec;
4726       }
4727       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4728         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4729         *cp1 = '\0';
4730         rms_nam_esll(dirnam) -= 9;
4731       }
4732       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4733       if (cp1 == NULL) { /* should never happen */
4734         sts = rms_free_search_context(&dirfab);
4735         Safefree(trndir);
4736         Safefree(esa);
4737         Safefree(vmsdir);
4738         return NULL;
4739       }
4740       term = *cp1;
4741       *cp1 = '\0';
4742       retlen = strlen(esa);
4743       cp1 = strrchr(esa,'.');
4744       /* ODS-5 directory specifications can have extra "." in them. */
4745       while (cp1 != NULL) {
4746         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4747           break;
4748         else {
4749            cp1--;
4750            while ((cp1 > esa) && (*cp1 != '.'))
4751              cp1--;
4752         }
4753         if (cp1 == esa)
4754           cp1 = NULL;
4755       }
4756
4757       if ((cp1) != NULL) {
4758         /* There's more than one directory in the path.  Just roll back. */
4759         *cp1 = term;
4760         if (buf) retspec = buf;
4761         else if (ts) Newx(retspec,retlen+7,char);
4762         else retspec = __fileify_retbuf;
4763         strcpy(retspec,esa);
4764       }
4765       else {
4766         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4767           /* Go back and expand rooted logical name */
4768           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4769 #ifdef NAM$M_NO_SHORT_UPCASE
4770           if (decc_efs_case_preserve)
4771             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4772 #endif
4773           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4774             sts = rms_free_search_context(&dirfab);
4775             Safefree(esa);
4776             Safefree(trndir);
4777             Safefree(vmsdir);
4778             set_errno(EVMSERR);
4779             set_vaxc_errno(dirfab.fab$l_sts);
4780             return NULL;
4781           }
4782           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4783           if (buf) retspec = buf;
4784           else if (ts) Newx(retspec,retlen+16,char);
4785           else retspec = __fileify_retbuf;
4786           cp1 = strstr(esa,"][");
4787           if (!cp1) cp1 = strstr(esa,"]<");
4788           dirlen = cp1 - esa;
4789           memcpy(retspec,esa,dirlen);
4790           if (!strncmp(cp1+2,"000000]",7)) {
4791             retspec[dirlen-1] = '\0';
4792             /* Not full ODS-5, just extra dots in directories for now */
4793             cp1 = retspec + dirlen - 1;
4794             while (cp1 > retspec)
4795             {
4796               if (*cp1 == '[')
4797                 break;
4798               if (*cp1 == '.') {
4799                 if (*(cp1-1) != '^')
4800                   break;
4801               }
4802               cp1--;
4803             }
4804             if (*cp1 == '.') *cp1 = ']';
4805             else {
4806               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4807               memmove(cp1+1,"000000]",7);
4808             }
4809           }
4810           else {
4811             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4812             retspec[retlen] = '\0';
4813             /* Convert last '.' to ']' */
4814             cp1 = retspec+retlen-1;
4815             while (*cp != '[') {
4816               cp1--;
4817               if (*cp1 == '.') {
4818                 /* Do not trip on extra dots in ODS-5 directories */
4819                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4820                 break;
4821               }
4822             }
4823             if (*cp1 == '.') *cp1 = ']';
4824             else {
4825               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4826               memmove(cp1+1,"000000]",7);
4827             }
4828           }
4829         }
4830         else {  /* This is a top-level dir.  Add the MFD to the path. */
4831           if (buf) retspec = buf;
4832           else if (ts) Newx(retspec,retlen+16,char);
4833           else retspec = __fileify_retbuf;
4834           cp1 = esa;
4835           cp2 = retspec;
4836           while (*cp1 != ':') *(cp2++) = *(cp1++);
4837           strcpy(cp2,":[000000]");
4838           cp1 += 2;
4839           strcpy(cp2+9,cp1);
4840         }
4841       }
4842       sts = rms_free_search_context(&dirfab);
4843       /* We've set up the string up through the filename.  Add the
4844          type and version, and we're done. */
4845       strcat(retspec,".DIR;1");
4846
4847       /* $PARSE may have upcased filespec, so convert output to lower
4848        * case if input contained any lowercase characters. */
4849       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4850       Safefree(trndir);
4851       Safefree(esa);
4852       Safefree(vmsdir);
4853       return retspec;
4854     }
4855 }  /* end of do_fileify_dirspec() */
4856 /*}}}*/
4857 /* External entry points */
4858 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4859 { return do_fileify_dirspec(dir,buf,0); }
4860 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4861 { return do_fileify_dirspec(dir,buf,1); }
4862
4863 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4864 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4865 {
4866     static char __pathify_retbuf[VMS_MAXRSS];
4867     unsigned long int retlen;
4868     char *retpath, *cp1, *cp2, *trndir;
4869     unsigned short int trnlnm_iter_count;
4870     STRLEN trnlen;
4871     int sts;
4872
4873     if (!dir || !*dir) {
4874       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4875     }
4876
4877     Newx(trndir, VMS_MAXRSS, char);
4878     if (*dir) strcpy(trndir,dir);
4879     else getcwd(trndir,VMS_MAXRSS - 1);
4880
4881     trnlnm_iter_count = 0;
4882     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4883            && my_trnlnm(trndir,trndir,0)) {
4884       trnlnm_iter_count++;
4885       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4886       trnlen = strlen(trndir);
4887
4888       /* Trap simple rooted lnms, and return lnm:[000000] */
4889       if (!strcmp(trndir+trnlen-2,".]")) {
4890         if (buf) retpath = buf;
4891         else if (ts) Newx(retpath,strlen(dir)+10,char);
4892         else retpath = __pathify_retbuf;
4893         strcpy(retpath,dir);
4894         strcat(retpath,":[000000]");
4895         Safefree(trndir);
4896         return retpath;
4897       }
4898     }
4899
4900     /* At this point we do not work with *dir, but the copy in
4901      * *trndir that is modifiable.
4902      */
4903
4904     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4905       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4906                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4907         retlen = 2 + (*(trndir+1) != '\0');
4908       else {
4909         if ( !(cp1 = strrchr(trndir,'/')) &&
4910              !(cp1 = strrchr(trndir,']')) &&
4911              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4912         if ((cp2 = strchr(cp1,'.')) != NULL &&
4913             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4914              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4915               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4916               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4917           int ver; char *cp3;
4918
4919           /* For EFS or ODS-5 look for the last dot */
4920           if (decc_efs_charset) {
4921             cp2 = strrchr(cp1,'.');
4922           }
4923           if (vms_process_case_tolerant) {
4924               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4925                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4926                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4927                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4928                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4929                             (ver || *cp3)))))) {
4930                 Safefree(trndir);
4931                 set_errno(ENOTDIR);
4932                 set_vaxc_errno(RMS$_DIR);
4933                 return NULL;
4934               }
4935           }
4936           else {
4937               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4938                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4939                   !*(cp2+3) || *(cp2+3) != 'R' ||
4940                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4941                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4942                             (ver || *cp3)))))) {
4943                 Safefree(trndir);
4944                 set_errno(ENOTDIR);
4945                 set_vaxc_errno(RMS$_DIR);
4946                 return NULL;
4947               }
4948           }
4949           retlen = cp2 - trndir + 1;
4950         }
4951         else {  /* No file type present.  Treat the filename as a directory. */
4952           retlen = strlen(trndir) + 1;
4953         }
4954       }
4955       if (buf) retpath = buf;
4956       else if (ts) Newx(retpath,retlen+1,char);
4957       else retpath = __pathify_retbuf;
4958       strncpy(retpath, trndir, retlen-1);
4959       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4960         retpath[retlen-1] = '/';      /* with '/', add it. */
4961         retpath[retlen] = '\0';
4962       }
4963       else retpath[retlen-1] = '\0';
4964     }
4965     else {  /* VMS-style directory spec */
4966       char *esa, *cp;
4967       unsigned long int sts, cmplen, haslower;
4968       struct FAB dirfab = cc$rms_fab;
4969       int dirlen;
4970       rms_setup_nam(savnam);
4971       rms_setup_nam(dirnam);
4972
4973       /* If we've got an explicit filename, we can just shuffle the string. */
4974       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4975              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4976         if ((cp2 = strchr(cp1,'.')) != NULL) {
4977           int ver; char *cp3;
4978           if (vms_process_case_tolerant) {
4979               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4980                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4981                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4982                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4983                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4984                             (ver || *cp3)))))) {
4985                Safefree(trndir);
4986                set_errno(ENOTDIR);
4987                set_vaxc_errno(RMS$_DIR);
4988                return NULL;
4989              }
4990           }
4991           else {
4992               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4993                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4994                   !*(cp2+3) || *(cp2+3) != 'R' ||
4995                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4996                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4997                             (ver || *cp3)))))) {
4998                Safefree(trndir);
4999                set_errno(ENOTDIR);
5000                set_vaxc_errno(RMS$_DIR);
5001                return NULL;
5002              }
5003           }
5004         }
5005         else {  /* No file type, so just draw name into directory part */
5006           for (cp2 = cp1; *cp2; cp2++) ;
5007         }
5008         *cp2 = *cp1;
5009         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5010         *cp1 = '.';
5011         /* We've now got a VMS 'path'; fall through */
5012       }
5013
5014       dirlen = strlen(trndir);
5015       if (trndir[dirlen-1] == ']' ||
5016           trndir[dirlen-1] == '>' ||
5017           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5018         if (buf) retpath = buf;
5019         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5020         else retpath = __pathify_retbuf;
5021         strcpy(retpath,trndir);
5022         Safefree(trndir);
5023         return retpath;
5024       }
5025       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5026       Newx(esa, VMS_MAXRSS, char);
5027       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5028       rms_bind_fab_nam(dirfab, dirnam);
5029       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5030 #ifdef NAM$M_NO_SHORT_UPCASE
5031       if (decc_efs_case_preserve)
5032           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5033 #endif
5034
5035       for (cp = trndir; *cp; cp++)
5036         if (islower(*cp)) { haslower = 1; break; }
5037
5038       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5039         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5040           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5041           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5042         }
5043         if (!sts) {
5044           Safefree(trndir);
5045           Safefree(esa);
5046           set_errno(EVMSERR);
5047           set_vaxc_errno(dirfab.fab$l_sts);
5048           return NULL;
5049         }
5050       }
5051       else {
5052         savnam = dirnam;
5053         /* Does the file really exist? */
5054         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5055           if (dirfab.fab$l_sts != RMS$_FNF) {
5056             int sts1;
5057             sts1 = rms_free_search_context(&dirfab);
5058             Safefree(trndir);
5059             Safefree(esa);
5060             set_errno(EVMSERR);
5061             set_vaxc_errno(dirfab.fab$l_sts);
5062             return NULL;
5063           }
5064           dirnam = savnam; /* No; just work with potential name */
5065         }
5066       }
5067       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5068         /* Yep; check version while we're at it, if it's there. */
5069         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5070         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5071           int sts2;
5072           /* Something other than .DIR[;1].  Bzzt. */
5073           sts2 = rms_free_search_context(&dirfab);
5074           Safefree(trndir);
5075           Safefree(esa);
5076           set_errno(ENOTDIR);
5077           set_vaxc_errno(RMS$_DIR);
5078           return NULL;
5079         }
5080       }
5081       /* OK, the type was fine.  Now pull any file name into the
5082          directory path. */
5083       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5084       else {
5085         cp1 = strrchr(esa,'>');
5086         *(rms_nam_typel(dirnam)) = '>';
5087       }
5088       *cp1 = '.';
5089       *(rms_nam_typel(dirnam) + 1) = '\0';
5090       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5091       if (buf) retpath = buf;
5092       else if (ts) Newx(retpath,retlen,char);
5093       else retpath = __pathify_retbuf;
5094       strcpy(retpath,esa);
5095       Safefree(esa);
5096       sts = rms_free_search_context(&dirfab);
5097       /* $PARSE may have upcased filespec, so convert output to lower
5098        * case if input contained any lowercase characters. */
5099       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5100     }
5101
5102     Safefree(trndir);
5103     return retpath;
5104 }  /* end of do_pathify_dirspec() */
5105 /*}}}*/
5106 /* External entry points */
5107 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5108 { return do_pathify_dirspec(dir,buf,0); }
5109 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5110 { return do_pathify_dirspec(dir,buf,1); }
5111
5112 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5113 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5114 {
5115   static char __tounixspec_retbuf[VMS_MAXRSS];
5116   char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5117   const char *cp2;
5118   int devlen, dirlen, retlen = VMS_MAXRSS;
5119   int expand = 1; /* guarantee room for leading and trailing slashes */
5120   unsigned short int trnlnm_iter_count;
5121   int cmp_rslt;
5122
5123   if (spec == NULL) return NULL;
5124   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5125   if (buf) rslt = buf;
5126   else if (ts) {
5127     retlen = strlen(spec);
5128     cp1 = strchr(spec,'[');
5129     if (!cp1) cp1 = strchr(spec,'<');
5130     if (cp1) {
5131       for (cp1++; *cp1; cp1++) {
5132         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5133         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5134           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5135       }
5136     }
5137     Newx(rslt,retlen+2+2*expand,char);
5138   }
5139   else rslt = __tounixspec_retbuf;
5140
5141   /* New VMS specific format needs translation
5142    * glob passes filenames with trailing '\n' and expects this preserved.
5143    */
5144   if (decc_posix_compliant_pathnames) {
5145     if (strncmp(spec, "\"^UP^", 5) == 0) {
5146       char * uspec;
5147       char *tunix;
5148       int tunix_len;
5149       int nl_flag;
5150
5151       Newx(tunix, VMS_MAXRSS + 1,char);
5152       strcpy(tunix, spec);
5153       tunix_len = strlen(tunix);
5154       nl_flag = 0;
5155       if (tunix[tunix_len - 1] == '\n') {
5156         tunix[tunix_len - 1] = '\"';
5157         tunix[tunix_len] = '\0';
5158         tunix_len--;
5159         nl_flag = 1;
5160       }
5161       uspec = decc$translate_vms(tunix);
5162       Safefree(tunix);
5163       if ((int)uspec > 0) {
5164         strcpy(rslt,uspec);
5165         if (nl_flag) {
5166           strcat(rslt,"\n");
5167         }
5168         else {
5169           /* If we can not translate it, makemaker wants as-is */
5170           strcpy(rslt, spec);
5171         }
5172         return rslt;
5173       }
5174     }
5175   }
5176
5177   cmp_rslt = 0; /* Presume VMS */
5178   cp1 = strchr(spec, '/');
5179   if (cp1 == NULL)
5180     cmp_rslt = 0;
5181
5182     /* Look for EFS ^/ */
5183     if (decc_efs_charset) {
5184       while (cp1 != NULL) {
5185         cp2 = cp1 - 1;
5186         if (*cp2 != '^') {
5187           /* Found illegal VMS, assume UNIX */
5188           cmp_rslt = 1;
5189           break;
5190         }
5191       cp1++;
5192       cp1 = strchr(cp1, '/');
5193     }
5194   }
5195
5196   /* Look for "." and ".." */
5197   if (decc_filename_unix_report) {
5198     if (spec[0] == '.') {
5199       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5200         cmp_rslt = 1;
5201       }
5202       else {
5203         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5204           cmp_rslt = 1;
5205         }
5206       }
5207     }
5208   }
5209   /* This is already UNIX or at least nothing VMS understands */
5210   if (cmp_rslt) {
5211     strcpy(rslt,spec);
5212     return rslt;
5213   }
5214
5215   cp1 = rslt;
5216   cp2 = spec;
5217   dirend = strrchr(spec,']');
5218   if (dirend == NULL) dirend = strrchr(spec,'>');
5219   if (dirend == NULL) dirend = strchr(spec,':');
5220   if (dirend == NULL) {
5221     strcpy(rslt,spec);
5222     return rslt;
5223   }
5224
5225   /* Special case 1 - sys$posix_root = / */
5226 #if __CRTL_VER >= 70000000
5227   if (!decc_disable_posix_root) {
5228     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5229       *cp1 = '/';
5230       cp1++;
5231       cp2 = cp2 + 15;
5232       }
5233   }
5234 #endif
5235
5236   /* Special case 2 - Convert NLA0: to /dev/null */
5237 #if __CRTL_VER < 70000000
5238   cmp_rslt = strncmp(spec,"NLA0:", 5);
5239   if (cmp_rslt != 0)
5240      cmp_rslt = strncmp(spec,"nla0:", 5);
5241 #else
5242   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5243 #endif
5244   if (cmp_rslt == 0) {
5245     strcpy(rslt, "/dev/null");
5246     cp1 = cp1 + 9;
5247     cp2 = cp2 + 5;
5248     if (spec[6] != '\0') {
5249       cp1[9] == '/';
5250       cp1++;
5251       cp2++;
5252     }
5253   }
5254
5255    /* Also handle special case "SYS$SCRATCH:" */
5256 #if __CRTL_VER < 70000000
5257   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5258   if (cmp_rslt != 0)
5259      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5260 #else
5261   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5262 #endif
5263   if (cmp_rslt == 0) {
5264   int islnm;
5265
5266     islnm = my_trnlnm(tmp, "TMP", 0);
5267     if (!islnm) {
5268       strcpy(rslt, "/tmp");
5269       cp1 = cp1 + 4;
5270       cp2 = cp2 + 12;
5271       if (spec[12] != '\0') {
5272         cp1[4] == '/';
5273         cp1++;
5274         cp2++;
5275       }
5276     }
5277   }
5278
5279   if (*cp2 != '[' && *cp2 != '<') {
5280     *(cp1++) = '/';
5281   }
5282   else {  /* the VMS spec begins with directories */
5283     cp2++;
5284     if (*cp2 == ']' || *cp2 == '>') {
5285       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5286       return rslt;
5287     }
5288     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5289       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5290         if (ts) Safefree(rslt);
5291         return NULL;
5292       }
5293       trnlnm_iter_count = 0;
5294       do {
5295         cp3 = tmp;
5296         while (*cp3 != ':' && *cp3) cp3++;
5297         *(cp3++) = '\0';
5298         if (strchr(cp3,']') != NULL) break;
5299         trnlnm_iter_count++;
5300         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5301       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5302       if (ts && !buf &&
5303           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5304         retlen = devlen + dirlen;
5305         Renew(rslt,retlen+1+2*expand,char);
5306         cp1 = rslt;
5307       }
5308       cp3 = tmp;
5309       *(cp1++) = '/';
5310       while (*cp3) {
5311         *(cp1++) = *(cp3++);
5312         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5313       }
5314       *(cp1++) = '/';
5315     }
5316     if ((*cp2 == '^')) {
5317         /* EFS file escape, pass the next character as is */
5318         /* Fix me: HEX encoding for UNICODE not implemented */
5319         cp2++;
5320     }
5321     else if ( *cp2 == '.') {
5322       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5323         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5324         cp2 += 3;
5325       }
5326       else cp2++;
5327     }
5328   }
5329   for (; cp2 <= dirend; cp2++) {
5330     if ((*cp2 == '^')) {
5331         /* EFS file escape, pass the next character as is */
5332         /* Fix me: HEX encoding for UNICODE not implemented */
5333         cp2++;
5334         *(cp1++) = *cp2;
5335     }
5336     if (*cp2 == ':') {
5337       *(cp1++) = '/';
5338       if (*(cp2+1) == '[') cp2++;
5339     }
5340     else if (*cp2 == ']' || *cp2 == '>') {
5341       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5342     }
5343     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5344       *(cp1++) = '/';
5345       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5346         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5347                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5348         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5349             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5350       }
5351       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5352         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5353         cp2 += 2;
5354       }
5355     }
5356     else if (*cp2 == '-') {
5357       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5358         while (*cp2 == '-') {
5359           cp2++;
5360           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5361         }
5362         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5363           if (ts) Safefree(rslt);                        /* filespecs like */
5364           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5365           return NULL;
5366         }
5367       }
5368       else *(cp1++) = *cp2;
5369     }
5370     else *(cp1++) = *cp2;
5371   }
5372   while (*cp2) *(cp1++) = *(cp2++);
5373   *cp1 = '\0';
5374
5375   /* This still leaves /000000/ when working with a
5376    * VMS device root or concealed root.
5377    */
5378   {
5379   int ulen;
5380   char * zeros;
5381
5382       ulen = strlen(rslt);
5383
5384       /* Get rid of "000000/ in rooted filespecs */
5385       if (ulen > 7) {
5386         zeros = strstr(rslt, "/000000/");
5387         if (zeros != NULL) {
5388           int mlen;
5389           mlen = ulen - (zeros - rslt) - 7;
5390           memmove(zeros, &zeros[7], mlen);
5391           ulen = ulen - 7;
5392           rslt[ulen] = '\0';
5393         }
5394       }
5395   }
5396
5397   return rslt;
5398
5399 }  /* end of do_tounixspec() */
5400 /*}}}*/
5401 /* External entry points */
5402 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5403 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5404
5405 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5406
5407 static int posix_to_vmsspec
5408   (char *vmspath, int vmspath_len, const char *unixpath) {
5409 int sts;
5410 struct FAB myfab = cc$rms_fab;
5411 struct NAML mynam = cc$rms_naml;
5412 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5413  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5414 char *esa;
5415 char *vms_delim;
5416 int dir_flag;
5417 int unixlen;
5418
5419   /* If not a posix spec already, convert it */
5420   dir_flag = 0;
5421   unixlen = strlen(unixpath);
5422   if (unixlen == 0) {
5423     vmspath[0] = '\0';
5424     return SS$_NORMAL;
5425   }
5426   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5427     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5428   }
5429   else {
5430     /* This is already a VMS specification, no conversion */
5431     unixlen--;
5432     strncpy(vmspath,unixpath, vmspath_len);
5433   }
5434   vmspath[vmspath_len] = 0;
5435   if (unixpath[unixlen - 1] == '/')
5436   dir_flag = 1;
5437   Newx(esa, VMS_MAXRSS, char);
5438   myfab.fab$l_fna = vmspath;
5439   myfab.fab$b_fns = strlen(vmspath);
5440   myfab.fab$l_naml = &mynam;
5441   mynam.naml$l_esa = NULL;
5442   mynam.naml$b_ess = 0;
5443   mynam.naml$l_long_expand = esa;
5444   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5445   mynam.naml$l_rsa = NULL;
5446   mynam.naml$b_rss = 0;
5447   if (decc_efs_case_preserve)
5448     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5449   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5450
5451   /* Set up the remaining naml fields */
5452   sts = sys$parse(&myfab);
5453
5454   /* It failed! Try again as a UNIX filespec */
5455   if (!(sts & 1)) {
5456     Safefree(esa);
5457     return sts;
5458   }
5459
5460    /* get the Device ID and the FID */
5461    sts = sys$search(&myfab);
5462    /* on any failure, returned the POSIX ^UP^ filespec */
5463    if (!(sts & 1)) {
5464       Safefree(esa);
5465       return sts;
5466    }
5467    specdsc.dsc$a_pointer = vmspath;
5468    specdsc.dsc$w_length = vmspath_len;
5469
5470    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5471    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5472    sts = lib$fid_to_name
5473       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5474
5475   /* on any failure, returned the POSIX ^UP^ filespec */
5476   if (!(sts & 1)) {
5477      /* This can happen if user does not have permission to read directories */
5478      if (strncmp(unixpath,"\"^UP^",5) != 0)
5479        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5480      else
5481        strcpy(vmspath, unixpath);
5482   }
5483   else {
5484     vmspath[specdsc.dsc$w_length] = 0;
5485
5486     /* Are we expecting a directory? */
5487     if (dir_flag != 0) {
5488     int i;
5489     char *eptr;
5490
5491       eptr = NULL;
5492
5493       i = specdsc.dsc$w_length - 1;
5494       while (i > 0) {
5495       int zercnt;
5496         zercnt = 0;
5497         /* Version must be '1' */
5498         if (vmspath[i--] != '1')
5499           break;
5500         /* Version delimiter is one of ".;" */
5501         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5502           break;
5503         i--;
5504         if (vmspath[i--] != 'R')
5505           break;
5506         if (vmspath[i--] != 'I')
5507           break;
5508         if (vmspath[i--] != 'D')
5509           break;
5510         if (vmspath[i--] != '.')
5511           break;
5512         eptr = &vmspath[i+1];
5513         while (i > 0) {
5514           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5515             if (vmspath[i-1] != '^') {
5516               if (zercnt != 6) {
5517                 *eptr = vmspath[i];
5518                 eptr[1] = '\0';
5519                 vmspath[i] = '.';
5520                 break;
5521               }
5522               else {
5523                 /* Get rid of 6 imaginary zero directory filename */
5524                 vmspath[i+1] = '\0';
5525               }
5526             }
5527           }
5528           if (vmspath[i] == '0')
5529             zercnt++;
5530           else
5531             zercnt = 10;
5532           i--;
5533         }
5534         break;
5535       }
5536     }
5537   }
5538   Safefree(esa);
5539   return sts;
5540 }
5541
5542 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5543 static int posix_to_vmsspec_hardway
5544   (char *vmspath, int vmspath_len, const char *unixpath) {
5545
5546 char *esa;
5547 const char *unixptr;
5548 char *vmsptr;
5549 const char *lastslash;
5550 const char *lastdot;
5551 int unixlen;
5552 int vmslen;
5553 int dir_start;
5554 int dir_dot;
5555 int quoted;
5556
5557
5558   unixptr = unixpath;
5559   dir_dot = 0;
5560
5561   /* Ignore leading "/" characters */
5562   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5563     unixptr++;
5564   }
5565   unixlen = strlen(unixptr);
5566
5567   /* Do nothing with blank paths */
5568   if (unixlen == 0) {
5569     vmspath[0] = '\0';
5570     return SS$_NORMAL;
5571   }
5572
5573   lastslash = strrchr(unixptr,'/');
5574   lastdot = strrchr(unixptr,'.');
5575
5576
5577   /* last dot is last dot or past end of string */
5578   if (lastdot == NULL)
5579     lastdot = unixptr + unixlen;
5580
5581   /* if no directories, set last slash to beginning of string */
5582   if (lastslash == NULL) {
5583     lastslash = unixptr;
5584   }
5585   else {
5586     /* Watch out for trailing "." after last slash, still a directory */
5587     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5588       lastslash = unixptr + unixlen;
5589     }
5590
5591     /* Watch out for traiing ".." after last slash, still a directory */
5592     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5593       lastslash = unixptr + unixlen;
5594     }
5595
5596     /* dots in directories are aways escaped */
5597     if (lastdot < lastslash)
5598       lastdot = unixptr + unixlen;
5599   }
5600
5601   /* if (unixptr < lastslash) then we are in a directory */
5602
5603   dir_start = 0;
5604   quoted = 0;
5605
5606   vmsptr = vmspath;
5607   vmslen = 0;
5608
5609   /* This could have a "^UP^ on the front */
5610   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5611     quoted = 1;
5612     unixptr+= 5;
5613   }
5614
5615   /* Start with the UNIX path */
5616   if (*unixptr != '/') {
5617     /* relative paths */
5618     if (lastslash > unixptr) {
5619     int dotdir_seen;
5620
5621       /* skip leading ./ */
5622       dotdir_seen = 0;
5623       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5624         dotdir_seen = 1;
5625         unixptr++;
5626         unixptr++;
5627       }
5628
5629       /* Are we still in a directory? */
5630       if (unixptr <= lastslash) {
5631         *vmsptr++ = '[';
5632         vmslen = 1;
5633         dir_start = 1;
5634
5635         /* if not backing up, then it is relative forward. */
5636         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5637               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5638           *vmsptr++ = '.';
5639           vmslen++;
5640           dir_dot = 1;
5641         }
5642        }
5643        else {
5644          if (dotdir_seen) {
5645            /* Perl wants an empty directory here to tell the difference
5646             * between a DCL commmand and a filename
5647             */
5648           *vmsptr++ = '[';
5649           *vmsptr++ = ']';
5650           vmslen = 2;
5651         }
5652       }
5653     }
5654     else {
5655       /* Handle two special files . and .. */
5656       if (unixptr[0] == '.') {
5657         if (unixptr[1] == '\0') {
5658           *vmsptr++ = '[';
5659           *vmsptr++ = ']';
5660           vmslen += 2;
5661           *vmsptr++ = '\0';
5662           return SS$_NORMAL;
5663         }
5664         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5665           *vmsptr++ = '[';
5666           *vmsptr++ = '-';
5667           *vmsptr++ = ']';
5668           vmslen += 3;
5669           *vmsptr++ = '\0';
5670           return SS$_NORMAL;
5671         }
5672       }
5673     }
5674   }
5675   else {        /* Absolute PATH handling */
5676   int sts;
5677   char * nextslash;
5678   int seg_len;
5679     /* Need to find out where root is */
5680
5681     /* In theory, this procedure should never get an absolute POSIX pathname
5682      * that can not be found on the POSIX root.
5683      * In practice, that can not be relied on, and things will show up
5684      * here that are a VMS device name or concealed logical name instead.
5685      * So to make things work, this procedure must be tolerant.
5686      */
5687     Newx(esa, vmspath_len, char);
5688
5689     sts = SS$_NORMAL;
5690     nextslash = strchr(&unixptr[1],'/');
5691     seg_len = 0;
5692     if (nextslash != NULL) {
5693       seg_len = nextslash - &unixptr[1];
5694       strncpy(vmspath, unixptr, seg_len + 1);
5695       vmspath[seg_len+1] = 0;
5696       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5697     }
5698
5699     if (sts & 1) {
5700       /* This is verified to be a real path */
5701
5702       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5703       strcpy(vmspath, esa);
5704       vmslen = strlen(vmspath);
5705       vmsptr = vmspath + vmslen;
5706       unixptr++;
5707       if (unixptr < lastslash) {
5708       char * rptr;
5709         vmsptr--;
5710         *vmsptr++ = '.';
5711         dir_start = 1;
5712         dir_dot = 1;
5713         if (vmslen > 7) {
5714         int cmp;
5715           rptr = vmsptr - 7;
5716           cmp = strcmp(rptr,"000000.");
5717           if (cmp == 0) {
5718             vmslen -= 7;
5719             vmsptr -= 7;
5720             vmsptr[1] = '\0';
5721           } /* removing 6 zeros */
5722         } /* vmslen < 7, no 6 zeros possible */
5723       } /* Not in a directory */
5724     } /* end of verified real path handling */
5725     else {
5726     int add_6zero;
5727     int islnm;
5728
5729       /* Ok, we have a device or a concealed root that is not in POSIX
5730        * or we have garbage.  Make the best of it.
5731        */
5732
5733       /* Posix to VMS destroyed this, so copy it again */
5734       strncpy(vmspath, &unixptr[1], seg_len);
5735       vmspath[seg_len] = 0;
5736       vmslen = seg_len;
5737       vmsptr = &vmsptr[vmslen];
5738       islnm = 0;
5739
5740       /* Now do we need to add the fake 6 zero directory to it? */
5741       add_6zero = 1;
5742       if ((*lastslash == '/') && (nextslash < lastslash)) {
5743         /* No there is another directory */
5744         add_6zero = 0;
5745       }
5746       else {
5747       int trnend;
5748
5749         /* now we have foo:bar or foo:[000000]bar to decide from */
5750         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5751         trnend = islnm ? islnm - 1 : 0;
5752
5753         /* if this was a logical name, ']' or '>' must be present */
5754         /* if not a logical name, then assume a device and hope. */
5755         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5756
5757         /* if log name and trailing '.' then rooted - treat as device */
5758         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5759
5760         /* Fix me, if not a logical name, a device lookup should be
5761          * done to see if the device is file structured.  If the device
5762          * is not file structured, the 6 zeros should not be put on.
5763          *
5764          * As it is, perl is occasionally looking for dev:[000000]tty.
5765          * which looks a little strange.
5766          */
5767
5768         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5769           /* No real directory present */
5770           add_6zero = 1;
5771         }
5772       }
5773
5774       /* Put the device delimiter on */
5775       *vmsptr++ = ':';
5776       vmslen++;
5777       unixptr = nextslash;
5778       unixptr++;
5779
5780       /* Start directory if needed */
5781       if (!islnm || add_6zero) {
5782         *vmsptr++ = '[';
5783         vmslen++;
5784         dir_start = 1;
5785       }
5786
5787       /* add fake 000000] if needed */
5788       if (add_6zero) {
5789         *vmsptr++ = '0';
5790         *vmsptr++ = '0';
5791         *vmsptr++ = '0';
5792         *vmsptr++ = '0';
5793         *vmsptr++ = '0';
5794         *vmsptr++ = '0';
5795         *vmsptr++ = ']';
5796         vmslen += 7;
5797         dir_start = 0;
5798       }
5799
5800     } /* non-POSIX translation */
5801     Safefree(esa);
5802   } /* End of relative/absolute path handling */
5803
5804   while ((*unixptr) && (vmslen < vmspath_len)){
5805   int dash_flag;
5806
5807     dash_flag = 0;
5808
5809     if (dir_start != 0) {
5810
5811       /* First characters in a directory are handled special */
5812       while ((*unixptr == '/') ||
5813              ((*unixptr == '.') &&
5814               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5815       int loop_flag;
5816
5817         loop_flag = 0;
5818
5819         /* Skip redundant / in specification */
5820         while ((*unixptr == '/') && (dir_start != 0)) {
5821           loop_flag = 1;
5822           unixptr++;
5823           if (unixptr == lastslash)
5824             break;
5825         }
5826         if (unixptr == lastslash)
5827           break;
5828
5829         /* Skip redundant ./ characters */
5830         while ((*unixptr == '.') &&
5831                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5832           loop_flag = 1;
5833           unixptr++;
5834           if (unixptr == lastslash)
5835             break;
5836           if (*unixptr == '/')
5837             unixptr++;
5838         }
5839         if (unixptr == lastslash)
5840           break;
5841
5842         /* Skip redundant ../ characters */
5843         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5844              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5845           /* Set the backing up flag */
5846           loop_flag = 1;
5847           dir_dot = 0;
5848           dash_flag = 1;
5849           *vmsptr++ = '-';
5850           vmslen++;
5851           unixptr++; /* first . */
5852           unixptr++; /* second . */
5853           if (unixptr == lastslash)
5854             break;
5855           if (*unixptr == '/') /* The slash */
5856             unixptr++;
5857         }
5858         if (unixptr == lastslash)
5859           break;
5860
5861         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5862         /* Not needed when VMS is pretending to be UNIX. */
5863
5864         /* Is this loop stuck because of too many dots? */
5865         if (loop_flag == 0) {
5866           /* Exit the loop and pass the rest through */
5867           break;
5868         }
5869       }
5870
5871       /* Are we done with directories yet? */
5872       if (unixptr >= lastslash) {
5873
5874         /* Watch out for trailing dots */
5875         if (dir_dot != 0) {
5876             vmslen --;
5877             vmsptr--;
5878         }
5879         *vmsptr++ = ']';
5880         vmslen++;
5881         dash_flag = 0;
5882         dir_start = 0;
5883         if (*unixptr == '/')
5884           unixptr++;
5885       }
5886       else {
5887         /* Have we stopped backing up? */
5888         if (dash_flag) {
5889           *vmsptr++ = '.';
5890           vmslen++;
5891           dash_flag = 0;
5892           /* dir_start continues to be = 1 */
5893         }
5894         if (*unixptr == '-') {
5895           *vmsptr++ = '^';
5896           *vmsptr++ = *unixptr++;
5897           vmslen += 2;
5898           dir_start = 0;
5899
5900           /* Now are we done with directories yet? */
5901           if (unixptr >= lastslash) {
5902
5903             /* Watch out for trailing dots */
5904             if (dir_dot != 0) {
5905               vmslen --;
5906               vmsptr--;
5907             }
5908
5909             *vmsptr++ = ']';
5910             vmslen++;
5911             dash_flag = 0;
5912             dir_start = 0;
5913           }
5914         }
5915       }
5916     }
5917
5918     /* All done? */
5919     if (*unixptr == '\0')
5920       break;
5921
5922     /* Normal characters - More EFS work probably needed */
5923     dir_start = 0;
5924     dir_dot = 0;
5925
5926     switch(*unixptr) {
5927     case '/':
5928         /* remove multiple / */
5929         while (unixptr[1] == '/') {
5930            unixptr++;
5931         }
5932         if (unixptr == lastslash) {
5933           /* Watch out for trailing dots */
5934           if (dir_dot != 0) {
5935             vmslen --;
5936             vmsptr--;
5937           }
5938           *vmsptr++ = ']';
5939         }
5940         else {
5941           dir_start = 1;
5942           *vmsptr++ = '.';
5943           dir_dot = 1;
5944
5945           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5946           /* Not needed when VMS is pretending to be UNIX. */
5947
5948         }
5949         dash_flag = 0;
5950         if (*unixptr != '\0')
5951           unixptr++;
5952         vmslen++;
5953         break;
5954     case '?':
5955         *vmsptr++ = '%';
5956         vmslen++;
5957         unixptr++;
5958         break;
5959     case ' ':
5960         *vmsptr++ = '^';
5961         *vmsptr++ = '_';
5962         vmslen += 2;
5963         unixptr++;
5964         break;
5965     case '.':
5966         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5967           *vmsptr++ = '^';
5968           *vmsptr++ = '.';
5969           vmslen += 2;
5970           unixptr++;
5971
5972           /* trailing dot ==> '^..' on VMS */
5973           if (*unixptr == '\0') {
5974             *vmsptr++ = '.';
5975             vmslen++;
5976           }
5977           *vmsptr++ = *unixptr++;
5978           vmslen ++;
5979         }
5980         if (quoted && (unixptr[1] == '\0')) {
5981           unixptr++;
5982           break;
5983         }
5984         *vmsptr++ = '^';
5985         *vmsptr++ = *unixptr++;
5986         vmslen += 2;
5987         break;
5988     case '~':
5989     case ';':
5990     case '\\':
5991         *vmsptr++ = '^';
5992         *vmsptr++ = *unixptr++;
5993         vmslen += 2;
5994         break;
5995     default:
5996         if (*unixptr != '\0') {
5997           *vmsptr++ = *unixptr++;
5998           vmslen++;
5999         }
6000         break;
6001     }
6002   }
6003
6004   /* Make sure directory is closed */
6005   if (unixptr == lastslash) {
6006     char *vmsptr2;
6007     vmsptr2 = vmsptr - 1;
6008
6009     if (*vmsptr2 != ']') {
6010       *vmsptr2--;
6011
6012       /* directories do not end in a dot bracket */
6013       if (*vmsptr2 == '.') {
6014         vmsptr2--;
6015
6016         /* ^. is allowed */
6017         if (*vmsptr2 != '^') {
6018           vmsptr--; /* back up over the dot */
6019         }
6020       }
6021       *vmsptr++ = ']';
6022     }
6023   }
6024   else {
6025     char *vmsptr2;
6026     /* Add a trailing dot if a file with no extension */
6027     vmsptr2 = vmsptr - 1;
6028     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6029         (*lastdot != '.')) {
6030         *vmsptr++ = '.';
6031         vmslen++;
6032     }
6033   }
6034
6035   *vmsptr = '\0';
6036   return SS$_NORMAL;
6037 }
6038 #endif
6039
6040 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6041 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6042   static char __tovmsspec_retbuf[VMS_MAXRSS];
6043   char *rslt, *dirend;
6044   char *lastdot;
6045   char *vms_delim;
6046   register char *cp1;
6047   const char *cp2;
6048   unsigned long int infront = 0, hasdir = 1;
6049   int rslt_len;
6050   int no_type_seen;
6051
6052   if (path == NULL) return NULL;
6053   rslt_len = VMS_MAXRSS;
6054   if (buf) rslt = buf;
6055   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6056   else rslt = __tovmsspec_retbuf;
6057   if (strpbrk(path,"]:>") ||
6058       (dirend = strrchr(path,'/')) == NULL) {
6059     if (path[0] == '.') {
6060       if (path[1] == '\0') strcpy(rslt,"[]");
6061       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6062       else strcpy(rslt,path); /* probably garbage */
6063     }
6064     else strcpy(rslt,path);
6065     return rslt;
6066   }
6067
6068    /* Posix specifications are now a native VMS format */
6069   /*--------------------------------------------------*/
6070 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6071   if (decc_posix_compliant_pathnames) {
6072     if (strncmp(path,"\"^UP^",5) == 0) {
6073       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6074       return rslt;
6075     }
6076   }
6077 #endif
6078
6079   vms_delim = strpbrk(path,"]:>");
6080
6081   if ((vms_delim != NULL) ||
6082       ((dirend = strrchr(path,'/')) == NULL)) {
6083
6084     /* VMS special characters found! */
6085
6086     if (path[0] == '.') {
6087       if (path[1] == '\0') strcpy(rslt,"[]");
6088       else if (path[1] == '.' && path[2] == '\0')
6089         strcpy(rslt,"[-]");
6090
6091       /* Dot preceeding a device or directory ? */
6092       else {
6093         /* If not in POSIX mode, pass it through and hope it works */
6094 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6095         if (!decc_posix_compliant_pathnames)
6096           strcpy(rslt,path); /* probably garbage */
6097         else
6098           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6099 #else
6100         strcpy(rslt,path); /* probably garbage */
6101 #endif
6102       }
6103     }
6104     else {
6105
6106        /* If no VMS characters and in POSIX mode, convert it!
6107         * This is the easiest way to get directory specifications
6108         * handled correctly in POSIX mode
6109         */
6110 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6111       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6112         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6113       else {
6114         /* No unix path separators - presume VMS already */
6115         strcpy(rslt,path);
6116       }
6117 #else
6118       strcpy(rslt,path); /* probably garbage */
6119 #endif
6120     }
6121     return rslt;
6122   }
6123
6124 /* If POSIX mode active, handle the conversion */
6125 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6126   if (decc_posix_compliant_pathnames) {
6127     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6128     return rslt;
6129   }
6130 #endif
6131
6132   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6133     if (!*(dirend+2)) dirend +=2;
6134     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6135     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6136   }
6137
6138   cp1 = rslt;
6139   cp2 = path;
6140   lastdot = strrchr(cp2,'.');
6141   if (*cp2 == '/') {
6142     char *trndev;
6143     int islnm, rooted;
6144     STRLEN trnend;
6145
6146     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6147     if (!*(cp2+1)) {
6148       if (decc_disable_posix_root) {
6149         strcpy(rslt,"sys$disk:[000000]");
6150       }
6151       else {
6152         strcpy(rslt,"sys$posix_root:[000000]");
6153       }
6154       return rslt;
6155     }
6156     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6157     *cp1 = '\0';
6158     Newx(trndev, VMS_MAXRSS, char);
6159     islnm =  my_trnlnm(rslt,trndev,0);
6160
6161      /* DECC special handling */
6162     if (!islnm) {
6163       if (strcmp(rslt,"bin") == 0) {
6164         strcpy(rslt,"sys$system");
6165         cp1 = rslt + 10;
6166         *cp1 = 0;
6167         islnm =  my_trnlnm(rslt,trndev,0);
6168       }
6169       else if (strcmp(rslt,"tmp") == 0) {
6170         strcpy(rslt,"sys$scratch");
6171         cp1 = rslt + 11;
6172         *cp1 = 0;
6173         islnm =  my_trnlnm(rslt,trndev,0);
6174       }
6175       else if (!decc_disable_posix_root) {
6176         strcpy(rslt, "sys$posix_root");
6177         cp1 = rslt + 13;
6178         *cp1 = 0;
6179         cp2 = path;
6180         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6181         islnm =  my_trnlnm(rslt,trndev,0);
6182       }
6183       else if (strcmp(rslt,"dev") == 0) {
6184         if (strncmp(cp2,"/null", 5) == 0) {
6185           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6186             strcpy(rslt,"NLA0");
6187             cp1 = rslt + 4;
6188             *cp1 = 0;
6189             cp2 = cp2 + 5;
6190             islnm =  my_trnlnm(rslt,trndev,0);
6191           }
6192         }
6193       }
6194     }
6195
6196     trnend = islnm ? strlen(trndev) - 1 : 0;
6197     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6198     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6199     /* If the first element of the path is a logical name, determine
6200      * whether it has to be translated so we can add more directories. */
6201     if (!islnm || rooted) {
6202       *(cp1++) = ':';
6203       *(cp1++) = '[';
6204       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6205       else cp2++;
6206     }
6207     else {
6208       if (cp2 != dirend) {
6209         strcpy(rslt,trndev);
6210         cp1 = rslt + trnend;
6211         if (*cp2 != 0) {
6212           *(cp1++) = '.';
6213           cp2++;
6214         }
6215       }
6216       else {
6217         if (decc_disable_posix_root) {
6218           *(cp1++) = ':';
6219           hasdir = 0;
6220         }
6221       }
6222     }
6223     Safefree(trndev);
6224   }
6225   else {
6226     *(cp1++) = '[';
6227     if (*cp2 == '.') {
6228       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6229         cp2 += 2;         /* skip over "./" - it's redundant */
6230         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6231       }
6232       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6233         *(cp1++) = '-';                                 /* "../" --> "-" */
6234         cp2 += 3;
6235       }
6236       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6237                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6238         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6239         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6240         cp2 += 4;
6241       }
6242       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6243         /* Escape the extra dots in EFS file specifications */
6244         *(cp1++) = '^';
6245       }
6246       if (cp2 > dirend) cp2 = dirend;
6247     }
6248     else *(cp1++) = '.';
6249   }
6250   for (; cp2 < dirend; cp2++) {
6251     if (*cp2 == '/') {
6252       if (*(cp2-1) == '/') continue;
6253       if (*(cp1-1) != '.') *(cp1++) = '.';
6254       infront = 0;
6255     }
6256     else if (!infront && *cp2 == '.') {
6257       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6258       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6259       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6260         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6261         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6262         else {  /* back up over previous directory name */
6263           cp1--;
6264           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6265           if (*(cp1-1) == '[') {
6266             memcpy(cp1,"000000.",7);
6267             cp1 += 7;
6268           }
6269         }
6270         cp2 += 2;
6271         if (cp2 == dirend) break;
6272       }
6273       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6274                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6275         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6276         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6277         if (!*(cp2+3)) {
6278           *(cp1++) = '.';  /* Simulate trailing '/' */
6279           cp2 += 2;  /* for loop will incr this to == dirend */
6280         }
6281         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6282       }
6283       else {
6284         if (decc_efs_charset == 0)
6285           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6286         else {
6287           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6288           *(cp1++) = '.';
6289         }
6290       }
6291     }
6292     else {
6293       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6294       if (*cp2 == '.') {
6295         if (decc_efs_charset == 0)
6296           *(cp1++) = '_';
6297         else {
6298           *(cp1++) = '^';
6299           *(cp1++) = '.';
6300         }
6301       }
6302       else                  *(cp1++) =  *cp2;
6303       infront = 1;
6304     }
6305   }
6306   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6307   if (hasdir) *(cp1++) = ']';
6308   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6309   /* fixme for ODS5 */
6310   no_type_seen = 0;
6311   if (cp2 > lastdot)
6312     no_type_seen = 1;
6313   while (*cp2) {
6314     switch(*cp2) {
6315     case '?':
6316         *(cp1++) = '%';
6317         cp2++;
6318     case ' ':
6319         *(cp1)++ = '^';
6320         *(cp1)++ = '_';
6321         cp2++;
6322         break;
6323     case '.':
6324         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6325             decc_readdir_dropdotnotype) {
6326           *(cp1)++ = '^';
6327           *(cp1)++ = '.';
6328           cp2++;
6329
6330           /* trailing dot ==> '^..' on VMS */
6331           if (*cp2 == '\0') {
6332             *(cp1++) = '.';
6333             no_type_seen = 0;
6334           }
6335         }
6336         else {
6337           *(cp1++) = *(cp2++);
6338           no_type_seen = 0;
6339         }
6340         break;
6341     case '\"':
6342     case '~':
6343     case '`':
6344     case '!':
6345     case '#':
6346     case '%':
6347     case '^':
6348     case '&':
6349     case '(':
6350     case ')':
6351     case '=':
6352     case '+':
6353     case '\'':
6354     case '@':
6355     case '[':
6356     case ']':
6357     case '{':
6358     case '}':
6359     case ':':
6360     case '\\':
6361     case '|':
6362     case '<':
6363     case '>':
6364         *(cp1++) = '^';
6365         *(cp1++) = *(cp2++);
6366         break;
6367     case ';':
6368         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6369          * which is wrong.  UNIX notation should be ".dir. unless
6370          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6371          * changing this behavior could break more things at this time.
6372          * efs character set effectively does not allow "." to be a version
6373          * delimiter as a further complication about changing this.
6374          */
6375         if (decc_filename_unix_report != 0) {
6376           *(cp1++) = '^';
6377         }
6378         *(cp1++) = *(cp2++);
6379         break;
6380     default:
6381         *(cp1++) = *(cp2++);
6382     }
6383   }
6384   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6385   char *lcp1;
6386     lcp1 = cp1;
6387     lcp1--;
6388      /* Fix me for "^]", but that requires making sure that you do
6389       * not back up past the start of the filename
6390       */
6391     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6392       *cp1++ = '.';
6393   }
6394   *cp1 = '\0';
6395
6396   return rslt;
6397
6398 }  /* end of do_tovmsspec() */
6399 /*}}}*/
6400 /* External entry points */
6401 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6402 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6403
6404 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6405 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6406   static char __tovmspath_retbuf[VMS_MAXRSS];
6407   int vmslen;
6408   char *pathified, *vmsified, *cp;
6409
6410   if (path == NULL) return NULL;
6411   Newx(pathified, VMS_MAXRSS, char);
6412   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6413     Safefree(pathified);
6414     return NULL;
6415   }
6416   Newx(vmsified, VMS_MAXRSS, char);
6417   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6418     Safefree(pathified);
6419     Safefree(vmsified);
6420     return NULL;
6421   }
6422   Safefree(pathified);
6423   if (buf) {
6424     Safefree(vmsified);
6425     return buf;
6426   }
6427   else if (ts) {
6428     vmslen = strlen(vmsified);
6429     Newx(cp,vmslen+1,char);
6430     memcpy(cp,vmsified,vmslen);
6431     cp[vmslen] = '\0';
6432     Safefree(vmsified);
6433     return cp;
6434   }
6435   else {
6436     strcpy(__tovmspath_retbuf,vmsified);
6437     Safefree(vmsified);
6438     return __tovmspath_retbuf;
6439   }
6440
6441 }  /* end of do_tovmspath() */
6442 /*}}}*/
6443 /* External entry points */
6444 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6445 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6446
6447
6448 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6449 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6450   static char __tounixpath_retbuf[VMS_MAXRSS];
6451   int unixlen;
6452   char *pathified, *unixified, *cp;
6453
6454   if (path == NULL) return NULL;
6455   Newx(pathified, VMS_MAXRSS, char);
6456   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6457     Safefree(pathified);
6458     return NULL;
6459   }
6460   Newx(unixified, VMS_MAXRSS, char);
6461   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6462     Safefree(pathified);
6463     Safefree(unixified);
6464     return NULL;
6465   }
6466   Safefree(pathified);
6467   if (buf) {
6468     Safefree(unixified);
6469     return buf;
6470   }
6471   else if (ts) {
6472     unixlen = strlen(unixified);
6473     Newx(cp,unixlen+1,char);
6474     memcpy(cp,unixified,unixlen);
6475     cp[unixlen] = '\0';
6476     Safefree(unixified);
6477     return cp;
6478   }
6479   else {
6480     strcpy(__tounixpath_retbuf,unixified);
6481     Safefree(unixified);
6482     return __tounixpath_retbuf;
6483   }
6484
6485 }  /* end of do_tounixpath() */
6486 /*}}}*/
6487 /* External entry points */
6488 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6489 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6490
6491 /*
6492  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6493  *
6494  *****************************************************************************
6495  *                                                                           *
6496  *  Copyright (C) 1989-1994 by                                               *
6497  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6498  *                                                                           *
6499  *  Permission is hereby  granted for the reproduction of this software,     *
6500  *  on condition that this copyright notice is included in the reproduction, *
6501  *  and that such reproduction is not for purposes of profit or material     *
6502  *  gain.                                                                    *
6503  *                                                                           *
6504  *  27-Aug-1994 Modified for inclusion in perl5                              *
6505  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6506  *****************************************************************************
6507  */
6508
6509 /*
6510  * getredirection() is intended to aid in porting C programs
6511  * to VMS (Vax-11 C).  The native VMS environment does not support
6512  * '>' and '<' I/O redirection, or command line wild card expansion,
6513  * or a command line pipe mechanism using the '|' AND background
6514  * command execution '&'.  All of these capabilities are provided to any
6515  * C program which calls this procedure as the first thing in the
6516  * main program.
6517  * The piping mechanism will probably work with almost any 'filter' type
6518  * of program.  With suitable modification, it may useful for other
6519  * portability problems as well.
6520  *
6521  * Author:  Mark Pizzolato      mark@infocomm.com
6522  */
6523 struct list_item
6524     {
6525     struct list_item *next;
6526     char *value;
6527     };
6528
6529 static void add_item(struct list_item **head,
6530                      struct list_item **tail,
6531                      char *value,
6532                      int *count);
6533
6534 static void mp_expand_wild_cards(pTHX_ char *item,
6535                                 struct list_item **head,
6536                                 struct list_item **tail,
6537                                 int *count);
6538
6539 static int background_process(pTHX_ int argc, char **argv);
6540
6541 static void pipe_and_fork(pTHX_ char **cmargv);
6542
6543 /*{{{ void getredirection(int *ac, char ***av)*/
6544 static void
6545 mp_getredirection(pTHX_ int *ac, char ***av)
6546 /*
6547  * Process vms redirection arg's.  Exit if any error is seen.
6548  * If getredirection() processes an argument, it is erased
6549  * from the vector.  getredirection() returns a new argc and argv value.
6550  * In the event that a background command is requested (by a trailing "&"),
6551  * this routine creates a background subprocess, and simply exits the program.
6552  *
6553  * Warning: do not try to simplify the code for vms.  The code
6554  * presupposes that getredirection() is called before any data is
6555  * read from stdin or written to stdout.
6556  *
6557  * Normal usage is as follows:
6558  *
6559  *      main(argc, argv)
6560  *      int             argc;
6561  *      char            *argv[];
6562  *      {
6563  *              getredirection(&argc, &argv);
6564  *      }
6565  */
6566 {
6567     int                 argc = *ac;     /* Argument Count         */
6568     char                **argv = *av;   /* Argument Vector        */
6569     char                *ap;            /* Argument pointer       */
6570     int                 j;              /* argv[] index           */
6571     int                 item_count = 0; /* Count of Items in List */
6572     struct list_item    *list_head = 0; /* First Item in List       */
6573     struct list_item    *list_tail;     /* Last Item in List        */
6574     char                *in = NULL;     /* Input File Name          */
6575     char                *out = NULL;    /* Output File Name         */
6576     char                *outmode = "w"; /* Mode to Open Output File */
6577     char                *err = NULL;    /* Error File Name          */
6578     char                *errmode = "w"; /* Mode to Open Error File  */
6579     int                 cmargc = 0;     /* Piped Command Arg Count  */
6580     char                **cmargv = NULL;/* Piped Command Arg Vector */
6581
6582     /*
6583      * First handle the case where the last thing on the line ends with
6584      * a '&'.  This indicates the desire for the command to be run in a
6585      * subprocess, so we satisfy that desire.
6586      */
6587     ap = argv[argc-1];
6588     if (0 == strcmp("&", ap))
6589        exit(background_process(aTHX_ --argc, argv));
6590     if (*ap && '&' == ap[strlen(ap)-1])
6591         {
6592         ap[strlen(ap)-1] = '\0';
6593        exit(background_process(aTHX_ argc, argv));
6594         }
6595     /*
6596      * Now we handle the general redirection cases that involve '>', '>>',
6597      * '<', and pipes '|'.
6598      */
6599     for (j = 0; j < argc; ++j)
6600         {
6601         if (0 == strcmp("<", argv[j]))
6602             {
6603             if (j+1 >= argc)
6604                 {
6605                 fprintf(stderr,"No input file after < on command line");
6606                 exit(LIB$_WRONUMARG);
6607                 }
6608             in = argv[++j];
6609             continue;
6610             }
6611         if ('<' == *(ap = argv[j]))
6612             {
6613             in = 1 + ap;
6614             continue;
6615             }
6616         if (0 == strcmp(">", ap))
6617             {
6618             if (j+1 >= argc)
6619                 {
6620                 fprintf(stderr,"No output file after > on command line");
6621                 exit(LIB$_WRONUMARG);
6622                 }
6623             out = argv[++j];
6624             continue;
6625             }
6626         if ('>' == *ap)
6627             {
6628             if ('>' == ap[1])
6629                 {
6630                 outmode = "a";
6631                 if ('\0' == ap[2])
6632                     out = argv[++j];
6633                 else
6634                     out = 2 + ap;
6635                 }
6636             else
6637                 out = 1 + ap;
6638             if (j >= argc)
6639                 {
6640                 fprintf(stderr,"No output file after > or >> on command line");
6641                 exit(LIB$_WRONUMARG);
6642                 }
6643             continue;
6644             }
6645         if (('2' == *ap) && ('>' == ap[1]))
6646             {
6647             if ('>' == ap[2])
6648                 {
6649                 errmode = "a";
6650                 if ('\0' == ap[3])
6651                     err = argv[++j];
6652                 else
6653                     err = 3 + ap;
6654                 }
6655             else
6656                 if ('\0' == ap[2])
6657                     err = argv[++j];
6658                 else
6659                     err = 2 + ap;
6660             if (j >= argc)
6661                 {
6662                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6663                 exit(LIB$_WRONUMARG);
6664                 }
6665             continue;
6666             }
6667         if (0 == strcmp("|", argv[j]))
6668             {
6669             if (j+1 >= argc)
6670                 {
6671                 fprintf(stderr,"No command into which to pipe on command line");
6672                 exit(LIB$_WRONUMARG);
6673                 }
6674             cmargc = argc-(j+1);
6675             cmargv = &argv[j+1];
6676             argc = j;
6677             continue;
6678             }
6679         if ('|' == *(ap = argv[j]))
6680             {
6681             ++argv[j];
6682             cmargc = argc-j;
6683             cmargv = &argv[j];
6684             argc = j;
6685             continue;
6686             }
6687         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6688         }
6689     /*
6690      * Allocate and fill in the new argument vector, Some Unix's terminate
6691      * the list with an extra null pointer.
6692      */
6693     Newx(argv, item_count+1, char *);
6694     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6695     *av = argv;
6696     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6697         argv[j] = list_head->value;
6698     *ac = item_count;
6699     if (cmargv != NULL)
6700         {
6701         if (out != NULL)
6702             {
6703             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6704             exit(LIB$_INVARGORD);
6705             }
6706         pipe_and_fork(aTHX_ cmargv);
6707         }
6708
6709     /* Check for input from a pipe (mailbox) */
6710
6711     if (in == NULL && 1 == isapipe(0))
6712         {
6713         char mbxname[L_tmpnam];
6714         long int bufsize;
6715         long int dvi_item = DVI$_DEVBUFSIZ;
6716         $DESCRIPTOR(mbxnam, "");
6717         $DESCRIPTOR(mbxdevnam, "");
6718
6719         /* Input from a pipe, reopen it in binary mode to disable       */
6720         /* carriage control processing.                                 */
6721
6722         fgetname(stdin, mbxname);
6723         mbxnam.dsc$a_pointer = mbxname;
6724         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6725         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6726         mbxdevnam.dsc$a_pointer = mbxname;
6727         mbxdevnam.dsc$w_length = sizeof(mbxname);
6728         dvi_item = DVI$_DEVNAM;
6729         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6730         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6731         set_errno(0);
6732         set_vaxc_errno(1);
6733         freopen(mbxname, "rb", stdin);
6734         if (errno != 0)
6735             {
6736             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6737             exit(vaxc$errno);
6738             }
6739         }
6740     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6741         {
6742         fprintf(stderr,"Can't open input file %s as stdin",in);
6743         exit(vaxc$errno);
6744         }
6745     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6746         {
6747         fprintf(stderr,"Can't open output file %s as stdout",out);
6748         exit(vaxc$errno);
6749         }
6750         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6751
6752     if (err != NULL) {
6753         if (strcmp(err,"&1") == 0) {
6754             dup2(fileno(stdout), fileno(stderr));
6755             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6756         } else {
6757         FILE *tmperr;
6758         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6759             {
6760             fprintf(stderr,"Can't open error file %s as stderr",err);
6761             exit(vaxc$errno);
6762             }
6763             fclose(tmperr);
6764            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6765                 {
6766                 exit(vaxc$errno);
6767                 }
6768             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6769         }
6770         }
6771 #ifdef ARGPROC_DEBUG
6772     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6773     for (j = 0; j < *ac;  ++j)
6774         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6775 #endif
6776    /* Clear errors we may have hit expanding wildcards, so they don't
6777       show up in Perl's $! later */
6778    set_errno(0); set_vaxc_errno(1);
6779 }  /* end of getredirection() */
6780 /*}}}*/
6781
6782 static void add_item(struct list_item **head,
6783                      struct list_item **tail,
6784                      char *value,
6785                      int *count)
6786 {
6787     if (*head == 0)
6788         {
6789         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6790         *tail = *head;
6791         }
6792     else {
6793         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6794         *tail = (*tail)->next;
6795         }
6796     (*tail)->value = value;
6797     ++(*count);
6798 }
6799
6800 static void mp_expand_wild_cards(pTHX_ char *item,
6801                               struct list_item **head,
6802                               struct list_item **tail,
6803                               int *count)
6804 {
6805 int expcount = 0;
6806 unsigned long int context = 0;
6807 int isunix = 0;
6808 int item_len = 0;
6809 char *had_version;
6810 char *had_device;
6811 int had_directory;
6812 char *devdir,*cp;
6813 char *vmsspec;
6814 $DESCRIPTOR(filespec, "");
6815 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6816 $DESCRIPTOR(resultspec, "");
6817 unsigned long int lff_flags = 0;
6818 int sts;
6819
6820 #ifdef VMS_LONGNAME_SUPPORT
6821     lff_flags = LIB$M_FIL_LONG_NAMES;
6822 #endif
6823
6824     for (cp = item; *cp; cp++) {
6825         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6826         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6827     }
6828     if (!*cp || isspace(*cp))
6829         {
6830         add_item(head, tail, item, count);
6831         return;
6832         }
6833     else
6834         {
6835      /* "double quoted" wild card expressions pass as is */
6836      /* From DCL that means using e.g.:                  */
6837      /* perl program """perl.*"""                        */
6838      item_len = strlen(item);
6839      if ( '"' == *item && '"' == item[item_len-1] )
6840        {
6841        item++;
6842        item[item_len-2] = '\0';
6843        add_item(head, tail, item, count);
6844        return;
6845        }
6846      }
6847     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6848     resultspec.dsc$b_class = DSC$K_CLASS_D;
6849     resultspec.dsc$a_pointer = NULL;
6850     Newx(vmsspec, VMS_MAXRSS, char);
6851     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6852       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6853     if (!isunix || !filespec.dsc$a_pointer)
6854       filespec.dsc$a_pointer = item;
6855     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6856     /*
6857      * Only return version specs, if the caller specified a version
6858      */
6859     had_version = strchr(item, ';');
6860     /*
6861      * Only return device and directory specs, if the caller specifed either.
6862      */
6863     had_device = strchr(item, ':');
6864     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6865
6866     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6867                                  (&filespec, &resultspec, &context,
6868                                   &defaultspec, 0, 0, &lff_flags)))
6869         {
6870         char *string;
6871         char *c;
6872
6873         Newx(string,resultspec.dsc$w_length+1,char);
6874         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6875         string[resultspec.dsc$w_length] = '\0';
6876         if (NULL == had_version)
6877             *(strrchr(string, ';')) = '\0';
6878         if ((!had_directory) && (had_device == NULL))
6879             {
6880             if (NULL == (devdir = strrchr(string, ']')))
6881                 devdir = strrchr(string, '>');
6882             strcpy(string, devdir + 1);
6883             }
6884         /*
6885          * Be consistent with what the C RTL has already done to the rest of
6886          * the argv items and lowercase all of these names.
6887          */
6888         if (!decc_efs_case_preserve) {
6889             for (c = string; *c; ++c)
6890             if (isupper(*c))
6891                 *c = tolower(*c);
6892         }
6893         if (isunix) trim_unixpath(string,item,1);
6894         add_item(head, tail, string, count);
6895         ++expcount;
6896     }
6897     Safefree(vmsspec);
6898     if (sts != RMS$_NMF)
6899         {
6900         set_vaxc_errno(sts);
6901         switch (sts)
6902             {
6903             case RMS$_FNF: case RMS$_DNF:
6904                 set_errno(ENOENT); break;
6905             case RMS$_DIR:
6906                 set_errno(ENOTDIR); break;
6907             case RMS$_DEV:
6908                 set_errno(ENODEV); break;
6909             case RMS$_FNM: case RMS$_SYN:
6910                 set_errno(EINVAL); break;
6911             case RMS$_PRV:
6912                 set_errno(EACCES); break;
6913             default:
6914                 _ckvmssts_noperl(sts);
6915             }
6916         }
6917     if (expcount == 0)
6918         add_item(head, tail, item, count);
6919     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6920     _ckvmssts_noperl(lib$find_file_end(&context));
6921 }
6922
6923 static int child_st[2];/* Event Flag set when child process completes   */
6924
6925 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6926
6927 static unsigned long int exit_handler(int *status)
6928 {
6929 short iosb[4];
6930
6931     if (0 == child_st[0])
6932         {
6933 #ifdef ARGPROC_DEBUG
6934         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6935 #endif
6936         fflush(stdout);     /* Have to flush pipe for binary data to    */
6937                             /* terminate properly -- <tp@mccall.com>    */
6938         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6939         sys$dassgn(child_chan);
6940         fclose(stdout);
6941         sys$synch(0, child_st);
6942         }
6943     return(1);
6944 }
6945
6946 static void sig_child(int chan)
6947 {
6948 #ifdef ARGPROC_DEBUG
6949     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6950 #endif
6951     if (child_st[0] == 0)
6952         child_st[0] = 1;
6953 }
6954
6955 static struct exit_control_block exit_block =
6956     {
6957     0,
6958     exit_handler,
6959     1,
6960     &exit_block.exit_status,
6961     0
6962     };
6963
6964 static void
6965 pipe_and_fork(pTHX_ char **cmargv)
6966 {
6967     PerlIO *fp;
6968     struct dsc$descriptor_s *vmscmd;
6969     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6970     int sts, j, l, ismcr, quote, tquote = 0;
6971
6972     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6973     vms_execfree(vmscmd);
6974
6975     j = l = 0;
6976     p = subcmd;
6977     q = cmargv[0];
6978     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6979               && toupper(*(q+2)) == 'R' && !*(q+3);
6980
6981     while (q && l < MAX_DCL_LINE_LENGTH) {
6982         if (!*q) {
6983             if (j > 0 && quote) {
6984                 *p++ = '"';
6985                 l++;
6986             }
6987             q = cmargv[++j];
6988             if (q) {
6989                 if (ismcr && j > 1) quote = 1;
6990                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6991                 *p++ = ' ';
6992                 l++;
6993                 if (quote || tquote) {
6994                     *p++ = '"';
6995                     l++;
6996                 }
6997         }
6998         } else {
6999             if ((quote||tquote) && *q == '"') {
7000                 *p++ = '"';
7001                 l++;
7002         }
7003             *p++ = *q++;
7004             l++;
7005         }
7006     }
7007     *p = '\0';
7008
7009     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7010     if (fp == Nullfp) {
7011         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7012         }
7013 }
7014
7015 static int background_process(pTHX_ int argc, char **argv)
7016 {
7017 char command[MAX_DCL_SYMBOL + 1] = "$";
7018 $DESCRIPTOR(value, "");
7019 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7020 static $DESCRIPTOR(null, "NLA0:");
7021 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7022 char pidstring[80];
7023 $DESCRIPTOR(pidstr, "");
7024 int pid;
7025 unsigned long int flags = 17, one = 1, retsts;
7026 int len;
7027
7028     strcat(command, argv[0]);
7029     len = strlen(command);
7030     while (--argc && (len < MAX_DCL_SYMBOL))
7031         {
7032         strcat(command, " \"");
7033         strcat(command, *(++argv));
7034         strcat(command, "\"");
7035         len = strlen(command);
7036         }
7037     value.dsc$a_pointer = command;
7038     value.dsc$w_length = strlen(value.dsc$a_pointer);
7039     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7040     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7041     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7042         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7043     }
7044     else {
7045         _ckvmssts_noperl(retsts);
7046     }
7047 #ifdef ARGPROC_DEBUG
7048     PerlIO_printf(Perl_debug_log, "%s\n", command);
7049 #endif
7050     sprintf(pidstring, "%08X", pid);
7051     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7052     pidstr.dsc$a_pointer = pidstring;
7053     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7054     lib$set_symbol(&pidsymbol, &pidstr);
7055     return(SS$_NORMAL);
7056 }
7057 /*}}}*/
7058 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7059
7060
7061 /* OS-specific initialization at image activation (not thread startup) */
7062 /* Older VAXC header files lack these constants */
7063 #ifndef JPI$_RIGHTS_SIZE
7064 #  define JPI$_RIGHTS_SIZE 817
7065 #endif
7066 #ifndef KGB$M_SUBSYSTEM
7067 #  define KGB$M_SUBSYSTEM 0x8
7068 #endif
7069
7070 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7071
7072 /*{{{void vms_image_init(int *, char ***)*/
7073 void
7074 vms_image_init(int *argcp, char ***argvp)
7075 {
7076   char eqv[LNM$C_NAMLENGTH+1] = "";
7077   unsigned int len, tabct = 8, tabidx = 0;
7078   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7079   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7080   unsigned short int dummy, rlen;
7081   struct dsc$descriptor_s **tabvec;
7082 #if defined(PERL_IMPLICIT_CONTEXT)
7083   pTHX = NULL;
7084 #endif
7085   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7086                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7087                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7088                                  {          0,                0,    0,      0} };
7089
7090 #ifdef KILL_BY_SIGPRC
7091     Perl_csighandler_init();
7092 #endif
7093
7094   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7095   _ckvmssts_noperl(iosb[0]);
7096   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7097     if (iprv[i]) {           /* Running image installed with privs? */
7098       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7099       will_taint = TRUE;
7100       break;
7101     }
7102   }
7103   /* Rights identifiers might trigger tainting as well. */
7104   if (!will_taint && (rlen || rsz)) {
7105     while (rlen < rsz) {
7106       /* We didn't get all the identifiers on the first pass.  Allocate a
7107        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7108        * were needed to hold all identifiers at time of last call; we'll
7109        * allocate that many unsigned long ints), and go back and get 'em.
7110        * If it gave us less than it wanted to despite ample buffer space,
7111        * something's broken.  Is your system missing a system identifier?
7112        */
7113       if (rsz <= jpilist[1].buflen) {
7114          /* Perl_croak accvios when used this early in startup. */
7115          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7116                          rsz, (unsigned long) jpilist[1].buflen,
7117                          "Check your rights database for corruption.\n");
7118          exit(SS$_ABORT);
7119       }
7120       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7121       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7122       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7123       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7124       _ckvmssts_noperl(iosb[0]);
7125     }
7126     mask = jpilist[1].bufadr;
7127     /* Check attribute flags for each identifier (2nd longword); protected
7128      * subsystem identifiers trigger tainting.
7129      */
7130     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7131       if (mask[i] & KGB$M_SUBSYSTEM) {
7132         will_taint = TRUE;
7133         break;
7134       }
7135     }
7136     if (mask != rlst) Safefree(mask);
7137   }
7138
7139   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7140    * logical, some versions of the CRTL will add a phanthom /000000/
7141    * directory.  This needs to be removed.
7142    */
7143   if (decc_filename_unix_report) {
7144   char * zeros;
7145   int ulen;
7146     ulen = strlen(argvp[0][0]);
7147     if (ulen > 7) {
7148       zeros = strstr(argvp[0][0], "/000000/");
7149       if (zeros != NULL) {
7150         int mlen;
7151         mlen = ulen - (zeros - argvp[0][0]) - 7;
7152         memmove(zeros, &zeros[7], mlen);
7153         ulen = ulen - 7;
7154         argvp[0][0][ulen] = '\0';
7155       }
7156     }
7157     /* It also may have a trailing dot that needs to be removed otherwise
7158      * it will be converted to VMS mode incorrectly.
7159      */
7160     ulen--;
7161     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7162       argvp[0][0][ulen] = '\0';
7163   }
7164
7165   /* We need to use this hack to tell Perl it should run with tainting,
7166    * since its tainting flag may be part of the PL_curinterp struct, which
7167    * hasn't been allocated when vms_image_init() is called.
7168    */
7169   if (will_taint) {
7170     char **newargv, **oldargv;
7171     oldargv = *argvp;
7172     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7173     newargv[0] = oldargv[0];
7174     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7175     strcpy(newargv[1], "-T");
7176     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7177     (*argcp)++;
7178     newargv[*argcp] = NULL;
7179     /* We orphan the old argv, since we don't know where it's come from,
7180      * so we don't know how to free it.
7181      */
7182     *argvp = newargv;
7183   }
7184   else {  /* Did user explicitly request tainting? */
7185     int i;
7186     char *cp, **av = *argvp;
7187     for (i = 1; i < *argcp; i++) {
7188       if (*av[i] != '-') break;
7189       for (cp = av[i]+1; *cp; cp++) {
7190         if (*cp == 'T') { will_taint = 1; break; }
7191         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7192                   strchr("DFIiMmx",*cp)) break;
7193       }
7194       if (will_taint) break;
7195     }
7196   }
7197
7198   for (tabidx = 0;
7199        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7200        tabidx++) {
7201     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7202     else if (tabidx >= tabct) {
7203       tabct += 8;
7204       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7205     }
7206     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7207     tabvec[tabidx]->dsc$w_length  = 0;
7208     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7209     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7210     tabvec[tabidx]->dsc$a_pointer = NULL;
7211     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7212   }
7213   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7214
7215   getredirection(argcp,argvp);
7216 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7217   {
7218 # include <reentrancy.h>
7219   decc$set_reentrancy(C$C_MULTITHREAD);
7220   }
7221 #endif
7222   return;
7223 }
7224 /*}}}*/
7225
7226
7227 /* trim_unixpath()
7228  * Trim Unix-style prefix off filespec, so it looks like what a shell
7229  * glob expansion would return (i.e. from specified prefix on, not
7230  * full path).  Note that returned filespec is Unix-style, regardless
7231  * of whether input filespec was VMS-style or Unix-style.
7232  *
7233  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7234  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7235  * vector of options; at present, only bit 0 is used, and if set tells
7236  * trim unixpath to try the current default directory as a prefix when
7237  * presented with a possibly ambiguous ... wildcard.
7238  *
7239  * Returns !=0 on success, with trimmed filespec replacing contents of
7240  * fspec, and 0 on failure, with contents of fpsec unchanged.
7241  */
7242 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7243 int
7244 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7245 {
7246   char *unixified, *unixwild,
7247        *template, *base, *end, *cp1, *cp2;
7248   register int tmplen, reslen = 0, dirs = 0;
7249
7250   Newx(unixwild, VMS_MAXRSS, char);
7251   if (!wildspec || !fspec) return 0;
7252   template = unixwild;
7253   if (strpbrk(wildspec,"]>:") != NULL) {
7254     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7255         Safefree(unixwild);
7256         return 0;
7257     }
7258   }
7259   else {
7260     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7261     unixwild[VMS_MAXRSS-1] = 0;
7262   }
7263   Newx(unixified, VMS_MAXRSS, char);
7264   if (strpbrk(fspec,"]>:") != NULL) {
7265     if (do_tounixspec(fspec,unixified,0) == NULL) {
7266         Safefree(unixwild);
7267         Safefree(unixified);
7268         return 0;
7269     }
7270     else base = unixified;
7271     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7272      * check to see that final result fits into (isn't longer than) fspec */
7273     reslen = strlen(fspec);
7274   }
7275   else base = fspec;
7276
7277   /* No prefix or absolute path on wildcard, so nothing to remove */
7278   if (!*template || *template == '/') {
7279     Safefree(unixwild);
7280     if (base == fspec) {
7281         Safefree(unixified);
7282         return 1;
7283     }
7284     tmplen = strlen(unixified);
7285     if (tmplen > reslen) {
7286         Safefree(unixified);
7287         return 0;  /* not enough space */
7288     }
7289     /* Copy unixified resultant, including trailing NUL */
7290     memmove(fspec,unixified,tmplen+1);
7291     Safefree(unixified);
7292     return 1;
7293   }
7294
7295   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7296   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7297     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7298     for (cp1 = end ;cp1 >= base; cp1--)
7299       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7300         { cp1++; break; }
7301     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7302     Safefree(unixified);
7303     Safefree(unixwild);
7304     return 1;
7305   }
7306   else {
7307     char *tpl, *lcres;
7308     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7309     int ells = 1, totells, segdirs, match;
7310     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7311                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7312
7313     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7314     totells = ells;
7315     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7316     Newx(tpl, VMS_MAXRSS, char);
7317     if (ellipsis == template && opts & 1) {
7318       /* Template begins with an ellipsis.  Since we can't tell how many
7319        * directory names at the front of the resultant to keep for an
7320        * arbitrary starting point, we arbitrarily choose the current
7321        * default directory as a starting point.  If it's there as a prefix,
7322        * clip it off.  If not, fall through and act as if the leading
7323        * ellipsis weren't there (i.e. return shortest possible path that
7324        * could match template).
7325        */
7326       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7327           Safefree(tpl);
7328           Safefree(unixified);
7329           Safefree(unixwild);
7330           return 0;
7331       }
7332       if (!decc_efs_case_preserve) {
7333         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7334           if (_tolower(*cp1) != _tolower(*cp2)) break;
7335       }
7336       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7337       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7338       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7339         memmove(fspec,cp2+1,end - cp2);
7340         Safefree(unixified);
7341         Safefree(unixwild);
7342         Safefree(tpl);
7343         return 1;
7344       }
7345     }
7346     /* First off, back up over constant elements at end of path */
7347     if (dirs) {
7348       for (front = end ; front >= base; front--)
7349          if (*front == '/' && !dirs--) { front++; break; }
7350     }
7351     Newx(lcres, VMS_MAXRSS, char);
7352     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7353          cp1++,cp2++) {
7354             if (!decc_efs_case_preserve) {
7355                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7356             }
7357             else {
7358                 *cp2 = *cp1;
7359             }
7360     }
7361     if (cp1 != '\0') {
7362         Safefree(unixified);
7363         Safefree(unixwild);
7364         Safefree(lcres);
7365         Safefree(tpl);
7366         return 0;  /* Path too long. */
7367     }
7368     lcend = cp2;
7369     *cp2 = '\0';  /* Pick up with memcpy later */
7370     lcfront = lcres + (front - base);
7371     /* Now skip over each ellipsis and try to match the path in front of it. */
7372     while (ells--) {
7373       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7374         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7375             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7376       if (cp1 < template) break; /* template started with an ellipsis */
7377       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7378         ellipsis = cp1; continue;
7379       }
7380       wilddsc.dsc$a_pointer = tpl;
7381       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7382       nextell = cp1;
7383       for (segdirs = 0, cp2 = tpl;
7384            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7385            cp1++, cp2++) {
7386          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7387          else {
7388             if (!decc_efs_case_preserve) {
7389               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7390             }
7391             else {
7392               *cp2 = *cp1;  /* else preserve case for match */
7393             }
7394          }
7395          if (*cp2 == '/') segdirs++;
7396       }
7397       if (cp1 != ellipsis - 1) {
7398           Safefree(unixified);
7399           Safefree(unixwild);
7400           Safefree(lcres);
7401           Safefree(tpl);
7402           return 0; /* Path too long */
7403       }
7404       /* Back up at least as many dirs as in template before matching */
7405       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7406         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7407       for (match = 0; cp1 > lcres;) {
7408         resdsc.dsc$a_pointer = cp1;
7409         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7410           match++;
7411           if (match == 1) lcfront = cp1;
7412         }
7413         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7414       }
7415       if (!match) {
7416         Safefree(unixified);
7417         Safefree(unixwild);
7418         Safefree(lcres);
7419         Safefree(tpl);
7420         return 0;  /* Can't find prefix ??? */
7421       }
7422       if (match > 1 && opts & 1) {
7423         /* This ... wildcard could cover more than one set of dirs (i.e.
7424          * a set of similar dir names is repeated).  If the template
7425          * contains more than 1 ..., upstream elements could resolve the
7426          * ambiguity, but it's not worth a full backtracking setup here.
7427          * As a quick heuristic, clip off the current default directory
7428          * if it's present to find the trimmed spec, else use the
7429          * shortest string that this ... could cover.
7430          */
7431         char def[NAM$C_MAXRSS+1], *st;
7432
7433         if (getcwd(def, sizeof def,0) == NULL) {
7434             Safefree(unixified);
7435             Safefree(unixwild);
7436             Safefree(lcres);
7437             Safefree(tpl);
7438             return 0;
7439         }
7440         if (!decc_efs_case_preserve) {
7441           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7442             if (_tolower(*cp1) != _tolower(*cp2)) break;
7443         }
7444         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7445         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7446         if (*cp1 == '\0' && *cp2 == '/') {
7447           memmove(fspec,cp2+1,end - cp2);
7448           Safefree(lcres);
7449           Safefree(unixified);
7450           Safefree(unixwild);
7451           Safefree(tpl);
7452           return 1;
7453         }
7454         /* Nope -- stick with lcfront from above and keep going. */
7455       }
7456     }
7457     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7458     Safefree(unixified);
7459     Safefree(unixwild);
7460     Safefree(lcres);
7461     Safefree(tpl);
7462     return 1;
7463     ellipsis = nextell;
7464   }
7465
7466 }  /* end of trim_unixpath() */
7467 /*}}}*/
7468
7469
7470 /*
7471  *  VMS readdir() routines.
7472  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7473  *
7474  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7475  *  Minor modifications to original routines.
7476  */
7477
7478 /* readdir may have been redefined by reentr.h, so make sure we get
7479  * the local version for what we do here.
7480  */
7481 #ifdef readdir
7482 # undef readdir
7483 #endif
7484 #if !defined(PERL_IMPLICIT_CONTEXT)
7485 # define readdir Perl_readdir
7486 #else
7487 # define readdir(a) Perl_readdir(aTHX_ a)
7488 #endif
7489
7490     /* Number of elements in vms_versions array */
7491 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7492
7493 /*
7494  *  Open a directory, return a handle for later use.
7495  */
7496 /*{{{ DIR *opendir(char*name) */
7497 MY_DIR *
7498 Perl_opendir(pTHX_ const char *name)
7499 {
7500     MY_DIR *dd;
7501     char dir[NAM$C_MAXRSS+1];
7502     Stat_t sb;
7503
7504     if (do_tovmspath(name,dir,0) == NULL) {
7505       return NULL;
7506     }
7507     /* Check access before stat; otherwise stat does not
7508      * accurately report whether it's a directory.
7509      */
7510     if (!cando_by_name(S_IRUSR,0,dir)) {
7511       /* cando_by_name has already set errno */
7512       return NULL;
7513     }
7514     if (flex_stat(dir,&sb) == -1) return NULL;
7515     if (!S_ISDIR(sb.st_mode)) {
7516       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7517       return NULL;
7518     }
7519     /* Get memory for the handle, and the pattern. */
7520     Newx(dd,1,MY_DIR);
7521     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7522
7523     /* Fill in the fields; mainly playing with the descriptor. */
7524     sprintf(dd->pattern, "%s*.*",dir);
7525     dd->context = 0;
7526     dd->count = 0;
7527     dd->vms_wantversions = 0;
7528     dd->pat.dsc$a_pointer = dd->pattern;
7529     dd->pat.dsc$w_length = strlen(dd->pattern);
7530     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7531     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7532 #if defined(USE_ITHREADS)
7533     Newx(dd->mutex,1,perl_mutex);
7534     MUTEX_INIT( (perl_mutex *) dd->mutex );
7535 #else
7536     dd->mutex = NULL;
7537 #endif
7538
7539     return dd;
7540 }  /* end of opendir() */
7541 /*}}}*/
7542
7543 /*
7544  *  Set the flag to indicate we want versions or not.
7545  */
7546 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7547 void
7548 vmsreaddirversions(MY_DIR *dd, int flag)
7549 {
7550     dd->vms_wantversions = flag;
7551 }
7552 /*}}}*/
7553
7554 /*
7555  *  Free up an opened directory.
7556  */
7557 /*{{{ void closedir(DIR *dd)*/
7558 void
7559 Perl_closedir(MY_DIR *dd)
7560 {
7561     int sts;
7562
7563     sts = lib$find_file_end(&dd->context);
7564     Safefree(dd->pattern);
7565 #if defined(USE_ITHREADS)
7566     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7567     Safefree(dd->mutex);
7568 #endif
7569     Safefree(dd);
7570 }
7571 /*}}}*/
7572
7573 /*
7574  *  Collect all the version numbers for the current file.
7575  */
7576 static void
7577 collectversions(pTHX_ MY_DIR *dd)
7578 {
7579     struct dsc$descriptor_s     pat;
7580     struct dsc$descriptor_s     res;
7581     struct my_dirent *e;
7582     char *p, *text, buff[sizeof dd->entry.d_name];
7583     int i;
7584     unsigned long context, tmpsts;
7585
7586     /* Convenient shorthand. */
7587     e = &dd->entry;
7588
7589     /* Add the version wildcard, ignoring the "*.*" put on before */
7590     i = strlen(dd->pattern);
7591     Newx(text,i + e->d_namlen + 3,char);
7592     strcpy(text, dd->pattern);
7593     sprintf(&text[i - 3], "%s;*", e->d_name);
7594
7595     /* Set up the pattern descriptor. */
7596     pat.dsc$a_pointer = text;
7597     pat.dsc$w_length = i + e->d_namlen - 1;
7598     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7599     pat.dsc$b_class = DSC$K_CLASS_S;
7600
7601     /* Set up result descriptor. */
7602     res.dsc$a_pointer = buff;
7603     res.dsc$w_length = sizeof buff - 2;
7604     res.dsc$b_dtype = DSC$K_DTYPE_T;
7605     res.dsc$b_class = DSC$K_CLASS_S;
7606
7607     /* Read files, collecting versions. */
7608     for (context = 0, e->vms_verscount = 0;
7609          e->vms_verscount < VERSIZE(e);
7610          e->vms_verscount++) {
7611         tmpsts = lib$find_file(&pat, &res, &context);
7612         if (tmpsts == RMS$_NMF || context == 0) break;
7613         _ckvmssts(tmpsts);
7614         buff[sizeof buff - 1] = '\0';
7615         if ((p = strchr(buff, ';')))
7616             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7617         else
7618             e->vms_versions[e->vms_verscount] = -1;
7619     }
7620
7621     _ckvmssts(lib$find_file_end(&context));
7622     Safefree(text);
7623
7624 }  /* end of collectversions() */
7625
7626 /*
7627  *  Read the next entry from the directory.
7628  */
7629 /*{{{ struct dirent *readdir(DIR *dd)*/
7630 struct my_dirent *
7631 Perl_readdir(pTHX_ MY_DIR *dd)
7632 {
7633     struct dsc$descriptor_s     res;
7634     char *p, buff[sizeof dd->entry.d_name];
7635     unsigned long int tmpsts;
7636
7637     /* Set up result descriptor, and get next file. */
7638     res.dsc$a_pointer = buff;
7639     res.dsc$w_length = sizeof buff - 2;
7640     res.dsc$b_dtype = DSC$K_DTYPE_T;
7641     res.dsc$b_class = DSC$K_CLASS_S;
7642     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7643     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7644     if (!(tmpsts & 1)) {
7645       set_vaxc_errno(tmpsts);
7646       switch (tmpsts) {
7647         case RMS$_PRV:
7648           set_errno(EACCES); break;
7649         case RMS$_DEV:
7650           set_errno(ENODEV); break;
7651         case RMS$_DIR:
7652           set_errno(ENOTDIR); break;
7653         case RMS$_FNF: case RMS$_DNF:
7654           set_errno(ENOENT); break;
7655         default:
7656           set_errno(EVMSERR);
7657       }
7658       return NULL;
7659     }
7660     dd->count++;
7661     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7662     if (!decc_efs_case_preserve) {
7663       buff[sizeof buff - 1] = '\0';
7664       for (p = buff; *p; p++) *p = _tolower(*p);
7665       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7666       *p = '\0';
7667     }
7668     else {
7669       /* we don't want to force to lowercase, just null terminate */
7670       buff[res.dsc$w_length] = '\0';
7671     }
7672     for (p = buff; *p; p++) *p = _tolower(*p);
7673     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7674     *p = '\0';
7675
7676     /* Skip any directory component and just copy the name. */
7677     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7678     else strcpy(dd->entry.d_name, buff);
7679
7680     /* Clobber the version. */
7681     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7682
7683     dd->entry.d_namlen = strlen(dd->entry.d_name);
7684     dd->entry.vms_verscount = 0;
7685     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7686     return &dd->entry;
7687
7688 }  /* end of readdir() */
7689 /*}}}*/
7690
7691 /*
7692  *  Read the next entry from the directory -- thread-safe version.
7693  */
7694 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7695 int
7696 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7697 {
7698     int retval;
7699
7700     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7701
7702     entry = readdir(dd);
7703     *result = entry;
7704     retval = ( *result == NULL ? errno : 0 );
7705
7706     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7707
7708     return retval;
7709
7710 }  /* end of readdir_r() */
7711 /*}}}*/
7712
7713 /*
7714  *  Return something that can be used in a seekdir later.
7715  */
7716 /*{{{ long telldir(DIR *dd)*/
7717 long
7718 Perl_telldir(MY_DIR *dd)
7719 {
7720     return dd->count;
7721 }
7722 /*}}}*/
7723
7724 /*
7725  *  Return to a spot where we used to be.  Brute force.
7726  */
7727 /*{{{ void seekdir(DIR *dd,long count)*/
7728 void
7729 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7730 {
7731     int vms_wantversions;
7732
7733     /* If we haven't done anything yet... */
7734     if (dd->count == 0)
7735         return;
7736
7737     /* Remember some state, and clear it. */
7738     vms_wantversions = dd->vms_wantversions;
7739     dd->vms_wantversions = 0;
7740     _ckvmssts(lib$find_file_end(&dd->context));
7741     dd->context = 0;
7742
7743     /* The increment is in readdir(). */
7744     for (dd->count = 0; dd->count < count; )
7745         readdir(dd);
7746
7747     dd->vms_wantversions = vms_wantversions;
7748
7749 }  /* end of seekdir() */
7750 /*}}}*/
7751
7752 /* VMS subprocess management
7753  *
7754  * my_vfork() - just a vfork(), after setting a flag to record that
7755  * the current script is trying a Unix-style fork/exec.
7756  *
7757  * vms_do_aexec() and vms_do_exec() are called in response to the
7758  * perl 'exec' function.  If this follows a vfork call, then they
7759  * call out the regular perl routines in doio.c which do an
7760  * execvp (for those who really want to try this under VMS).
7761  * Otherwise, they do exactly what the perl docs say exec should
7762  * do - terminate the current script and invoke a new command
7763  * (See below for notes on command syntax.)
7764  *
7765  * do_aspawn() and do_spawn() implement the VMS side of the perl
7766  * 'system' function.
7767  *
7768  * Note on command arguments to perl 'exec' and 'system': When handled
7769  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7770  * are concatenated to form a DCL command string.  If the first arg
7771  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7772  * the command string is handed off to DCL directly.  Otherwise,
7773  * the first token of the command is taken as the filespec of an image
7774  * to run.  The filespec is expanded using a default type of '.EXE' and
7775  * the process defaults for device, directory, etc., and if found, the resultant
7776  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7777  * the command string as parameters.  This is perhaps a bit complicated,
7778  * but I hope it will form a happy medium between what VMS folks expect
7779  * from lib$spawn and what Unix folks expect from exec.
7780  */
7781
7782 static int vfork_called;
7783
7784 /*{{{int my_vfork()*/
7785 int
7786 my_vfork()
7787 {
7788   vfork_called++;
7789   return vfork();
7790 }
7791 /*}}}*/
7792
7793
7794 static void
7795 vms_execfree(struct dsc$descriptor_s *vmscmd)
7796 {
7797   if (vmscmd) {
7798       if (vmscmd->dsc$a_pointer) {
7799           Safefree(vmscmd->dsc$a_pointer);
7800       }
7801       Safefree(vmscmd);
7802   }
7803 }
7804
7805 static char *
7806 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7807 {
7808   char *junk, *tmps = Nullch;
7809   register size_t cmdlen = 0;
7810   size_t rlen;
7811   register SV **idx;
7812   STRLEN n_a;
7813
7814   idx = mark;
7815   if (really) {
7816     tmps = SvPV(really,rlen);
7817     if (*tmps) {
7818       cmdlen += rlen + 1;
7819       idx++;
7820     }
7821   }
7822
7823   for (idx++; idx <= sp; idx++) {
7824     if (*idx) {
7825       junk = SvPVx(*idx,rlen);
7826       cmdlen += rlen ? rlen + 1 : 0;
7827     }
7828   }
7829   Newx(PL_Cmd,cmdlen+1,char);
7830
7831   if (tmps && *tmps) {
7832     strcpy(PL_Cmd,tmps);
7833     mark++;
7834   }
7835   else *PL_Cmd = '\0';
7836   while (++mark <= sp) {
7837     if (*mark) {
7838       char *s = SvPVx(*mark,n_a);
7839       if (!*s) continue;
7840       if (*PL_Cmd) strcat(PL_Cmd," ");
7841       strcat(PL_Cmd,s);
7842     }
7843   }
7844   return PL_Cmd;
7845
7846 }  /* end of setup_argstr() */
7847
7848
7849 static unsigned long int
7850 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7851                    struct dsc$descriptor_s **pvmscmd)
7852 {
7853   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7854   char image_name[NAM$C_MAXRSS+1];
7855   char image_argv[NAM$C_MAXRSS+1];
7856   $DESCRIPTOR(defdsc,".EXE");
7857   $DESCRIPTOR(defdsc2,".");
7858   $DESCRIPTOR(resdsc,resspec);
7859   struct dsc$descriptor_s *vmscmd;
7860   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7861   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7862   register char *s, *rest, *cp, *wordbreak;
7863   char * cmd;
7864   int cmdlen;
7865   register int isdcl;
7866
7867   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7868
7869   /* Make a copy for modification */
7870   cmdlen = strlen(incmd);
7871   Newx(cmd, cmdlen+1, char);
7872   strncpy(cmd, incmd, cmdlen);
7873   cmd[cmdlen] = 0;
7874   image_name[0] = 0;
7875   image_argv[0] = 0;
7876
7877   vmscmd->dsc$a_pointer = NULL;
7878   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7879   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7880   vmscmd->dsc$w_length = 0;
7881   if (pvmscmd) *pvmscmd = vmscmd;
7882
7883   if (suggest_quote) *suggest_quote = 0;
7884
7885   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7886     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7887     Safefree(cmd);
7888   }
7889
7890   s = cmd;
7891
7892   while (*s && isspace(*s)) s++;
7893
7894   if (*s == '@' || *s == '$') {
7895     vmsspec[0] = *s;  rest = s + 1;
7896     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7897   }
7898   else { cp = vmsspec; rest = s; }
7899   if (*rest == '.' || *rest == '/') {
7900     char *cp2;
7901     for (cp2 = resspec;
7902          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7903          rest++, cp2++) *cp2 = *rest;
7904     *cp2 = '\0';
7905     if (do_tovmsspec(resspec,cp,0)) {
7906       s = vmsspec;
7907       if (*rest) {
7908         for (cp2 = vmsspec + strlen(vmsspec);
7909              *rest && cp2 - vmsspec < sizeof vmsspec;
7910              rest++, cp2++) *cp2 = *rest;
7911         *cp2 = '\0';
7912       }
7913     }
7914   }
7915   /* Intuit whether verb (first word of cmd) is a DCL command:
7916    *   - if first nonspace char is '@', it's a DCL indirection
7917    * otherwise
7918    *   - if verb contains a filespec separator, it's not a DCL command
7919    *   - if it doesn't, caller tells us whether to default to a DCL
7920    *     command, or to a local image unless told it's DCL (by leading '$')
7921    */
7922   if (*s == '@') {
7923       isdcl = 1;
7924       if (suggest_quote) *suggest_quote = 1;
7925   } else {
7926     register char *filespec = strpbrk(s,":<[.;");
7927     rest = wordbreak = strpbrk(s," \"\t/");
7928     if (!wordbreak) wordbreak = s + strlen(s);
7929     if (*s == '$') check_img = 0;
7930     if (filespec && (filespec < wordbreak)) isdcl = 0;
7931     else isdcl = !check_img;
7932   }
7933
7934   if (!isdcl) {
7935     imgdsc.dsc$a_pointer = s;
7936     imgdsc.dsc$w_length = wordbreak - s;
7937     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7938     if (!(retsts&1)) {
7939         _ckvmssts(lib$find_file_end(&cxt));
7940         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7941       if (!(retsts & 1) && *s == '$') {
7942         _ckvmssts(lib$find_file_end(&cxt));
7943         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7944         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7945         if (!(retsts&1)) {
7946           _ckvmssts(lib$find_file_end(&cxt));
7947           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7948         }
7949       }
7950     }
7951     _ckvmssts(lib$find_file_end(&cxt));
7952
7953     if (retsts & 1) {
7954       FILE *fp;
7955       s = resspec;
7956       while (*s && !isspace(*s)) s++;
7957       *s = '\0';
7958
7959       /* check that it's really not DCL with no file extension */
7960       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7961       if (fp) {
7962         char b[256] = {0,0,0,0};
7963         read(fileno(fp), b, 256);
7964         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7965         if (isdcl) {
7966           int shebang_len;
7967
7968           /* Check for script */
7969           shebang_len = 0;
7970           if ((b[0] == '#') && (b[1] == '!'))
7971              shebang_len = 2;
7972 #ifdef ALTERNATE_SHEBANG
7973           else {
7974             shebang_len = strlen(ALTERNATE_SHEBANG);
7975             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7976               char * perlstr;
7977                 perlstr = strstr("perl",b);
7978                 if (perlstr == NULL)
7979                   shebang_len = 0;
7980             }
7981             else
7982               shebang_len = 0;
7983           }
7984 #endif
7985
7986           if (shebang_len > 0) {
7987           int i;
7988           int j;
7989           char tmpspec[NAM$C_MAXRSS + 1];
7990
7991             i = shebang_len;
7992              /* Image is following after white space */
7993             /*--------------------------------------*/
7994             while (isprint(b[i]) && isspace(b[i]))
7995                 i++;
7996
7997             j = 0;
7998             while (isprint(b[i]) && !isspace(b[i])) {
7999                 tmpspec[j++] = b[i++];
8000                 if (j >= NAM$C_MAXRSS)
8001                    break;
8002             }
8003             tmpspec[j] = '\0';
8004
8005              /* There may be some default parameters to the image */
8006             /*---------------------------------------------------*/
8007             j = 0;
8008             while (isprint(b[i])) {
8009                 image_argv[j++] = b[i++];
8010                 if (j >= NAM$C_MAXRSS)
8011                    break;
8012             }
8013             while ((j > 0) && !isprint(image_argv[j-1]))
8014                 j--;
8015             image_argv[j] = 0;
8016
8017             /* It will need to be converted to VMS format and validated */
8018             if (tmpspec[0] != '\0') {
8019               char * iname;
8020
8021                /* Try to find the exact program requested to be run */
8022               /*---------------------------------------------------*/
8023               iname = do_rmsexpand
8024                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8025               if (iname != NULL) {
8026                 if (cando_by_name(S_IXUSR,0,image_name)) {
8027                   /* MCR prefix needed */
8028                   isdcl = 0;
8029                 }
8030                 else {
8031                    /* Try again with a null type */
8032                   /*----------------------------*/
8033                   iname = do_rmsexpand
8034                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8035                   if (iname != NULL) {
8036                     if (cando_by_name(S_IXUSR,0,image_name)) {
8037                       /* MCR prefix needed */
8038                       isdcl = 0;
8039                     }
8040                   }
8041                 }
8042
8043                  /* Did we find the image to run the script? */
8044                 /*------------------------------------------*/
8045                 if (isdcl) {
8046                   char *tchr;
8047
8048                    /* Assume DCL or foreign command exists */
8049                   /*--------------------------------------*/
8050                   tchr = strrchr(tmpspec, '/');
8051                   if (tchr != NULL) {
8052                     tchr++;
8053                   }
8054                   else {
8055                     tchr = tmpspec;
8056                   }
8057                   strcpy(image_name, tchr);
8058                 }
8059               }
8060             }
8061           }
8062         }
8063         fclose(fp);
8064       }
8065       if (check_img && isdcl) return RMS$_FNF;
8066
8067       if (cando_by_name(S_IXUSR,0,resspec)) {
8068         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8069         if (!isdcl) {
8070             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8071             if (image_name[0] != 0) {
8072                 strcat(vmscmd->dsc$a_pointer, image_name);
8073                 strcat(vmscmd->dsc$a_pointer, " ");
8074             }
8075         } else if (image_name[0] != 0) {
8076             strcpy(vmscmd->dsc$a_pointer, image_name);
8077             strcat(vmscmd->dsc$a_pointer, " ");
8078         } else {
8079             strcpy(vmscmd->dsc$a_pointer,"@");
8080         }
8081         if (suggest_quote) *suggest_quote = 1;
8082
8083         /* If there is an image name, use original command */
8084         if (image_name[0] == 0)
8085             strcat(vmscmd->dsc$a_pointer,resspec);
8086         else {
8087             rest = cmd;
8088             while (*rest && isspace(*rest)) rest++;
8089         }
8090
8091         if (image_argv[0] != 0) {
8092           strcat(vmscmd->dsc$a_pointer,image_argv);
8093           strcat(vmscmd->dsc$a_pointer, " ");
8094         }
8095         if (rest) {
8096            int rest_len;
8097            int vmscmd_len;
8098
8099            rest_len = strlen(rest);
8100            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8101            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8102               strcat(vmscmd->dsc$a_pointer,rest);
8103            else
8104              retsts = CLI$_BUFOVF;
8105         }
8106         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8107         Safefree(cmd);
8108         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8109       }
8110       else retsts = RMS$_PRV;
8111     }
8112   }
8113   /* It's either a DCL command or we couldn't find a suitable image */
8114   vmscmd->dsc$w_length = strlen(cmd);
8115 /*  if (cmd == PL_Cmd) {
8116       vmscmd->dsc$a_pointer = PL_Cmd;
8117       if (suggest_quote) *suggest_quote = 1;
8118   }
8119   else  */
8120       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8121
8122   Safefree(cmd);
8123
8124   /* check if it's a symbol (for quoting purposes) */
8125   if (suggest_quote && !*suggest_quote) {
8126     int iss;
8127     char equiv[LNM$C_NAMLENGTH];
8128     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8129     eqvdsc.dsc$a_pointer = equiv;
8130
8131     iss = lib$get_symbol(vmscmd,&eqvdsc);
8132     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8133   }
8134   if (!(retsts & 1)) {
8135     /* just hand off status values likely to be due to user error */
8136     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8137         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8138        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8139     else { _ckvmssts(retsts); }
8140   }
8141
8142   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8143
8144 }  /* end of setup_cmddsc() */
8145
8146
8147 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8148 bool
8149 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8150 {
8151   if (sp > mark) {
8152     if (vfork_called) {           /* this follows a vfork - act Unixish */
8153       vfork_called--;
8154       if (vfork_called < 0) {
8155         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8156         vfork_called = 0;
8157       }
8158       else return do_aexec(really,mark,sp);
8159     }
8160                                            /* no vfork - act VMSish */
8161     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8162
8163   }
8164
8165   return FALSE;
8166 }  /* end of vms_do_aexec() */
8167 /*}}}*/
8168
8169 /* {{{bool vms_do_exec(char *cmd) */
8170 bool
8171 Perl_vms_do_exec(pTHX_ const char *cmd)
8172 {
8173   struct dsc$descriptor_s *vmscmd;
8174
8175   if (vfork_called) {             /* this follows a vfork - act Unixish */
8176     vfork_called--;
8177     if (vfork_called < 0) {
8178       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8179       vfork_called = 0;
8180     }
8181     else return do_exec(cmd);
8182   }
8183
8184   {                               /* no vfork - act VMSish */
8185     unsigned long int retsts;
8186
8187     TAINT_ENV();
8188     TAINT_PROPER("exec");
8189     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8190       retsts = lib$do_command(vmscmd);
8191
8192     switch (retsts) {
8193       case RMS$_FNF: case RMS$_DNF:
8194         set_errno(ENOENT); break;
8195       case RMS$_DIR:
8196         set_errno(ENOTDIR); break;
8197       case RMS$_DEV:
8198         set_errno(ENODEV); break;
8199       case RMS$_PRV:
8200         set_errno(EACCES); break;
8201       case RMS$_SYN:
8202         set_errno(EINVAL); break;
8203       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8204         set_errno(E2BIG); break;
8205       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8206         _ckvmssts(retsts); /* fall through */
8207       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8208         set_errno(EVMSERR);
8209     }
8210     set_vaxc_errno(retsts);
8211     if (ckWARN(WARN_EXEC)) {
8212       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8213              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8214     }
8215     vms_execfree(vmscmd);
8216   }
8217
8218   return FALSE;
8219
8220 }  /* end of vms_do_exec() */
8221 /*}}}*/
8222
8223 unsigned long int Perl_do_spawn(pTHX_ const char *);
8224
8225 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8226 unsigned long int
8227 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8228 {
8229   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8230
8231   return SS$_ABORT;
8232 }  /* end of do_aspawn() */
8233 /*}}}*/
8234
8235 /* {{{unsigned long int do_spawn(char *cmd) */
8236 unsigned long int
8237 Perl_do_spawn(pTHX_ const char *cmd)
8238 {
8239   unsigned long int sts, substs;
8240
8241   TAINT_ENV();
8242   TAINT_PROPER("spawn");
8243   if (!cmd || !*cmd) {
8244     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8245     if (!(sts & 1)) {
8246       switch (sts) {
8247         case RMS$_FNF:  case RMS$_DNF:
8248           set_errno(ENOENT); break;
8249         case RMS$_DIR:
8250           set_errno(ENOTDIR); break;
8251         case RMS$_DEV:
8252           set_errno(ENODEV); break;
8253         case RMS$_PRV:
8254           set_errno(EACCES); break;
8255         case RMS$_SYN:
8256           set_errno(EINVAL); break;
8257         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8258           set_errno(E2BIG); break;
8259         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8260           _ckvmssts(sts); /* fall through */
8261         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8262           set_errno(EVMSERR);
8263       }
8264       set_vaxc_errno(sts);
8265       if (ckWARN(WARN_EXEC)) {
8266         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8267                     Strerror(errno));
8268       }
8269     }
8270     sts = substs;
8271   }
8272   else {
8273     PerlIO * fp;
8274     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8275     if (fp != NULL)
8276       my_pclose(fp);
8277   }
8278   return sts;
8279 }  /* end of do_spawn() */
8280 /*}}}*/
8281
8282
8283 static unsigned int *sockflags, sockflagsize;
8284
8285 /*
8286  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8287  * routines found in some versions of the CRTL can't deal with sockets.
8288  * We don't shim the other file open routines since a socket isn't
8289  * likely to be opened by a name.
8290  */
8291 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8292 FILE *my_fdopen(int fd, const char *mode)
8293 {
8294   FILE *fp = fdopen(fd, mode);
8295
8296   if (fp) {
8297     unsigned int fdoff = fd / sizeof(unsigned int);
8298     Stat_t sbuf; /* native stat; we don't need flex_stat */
8299     if (!sockflagsize || fdoff > sockflagsize) {
8300       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8301       else           Newx  (sockflags,fdoff+2,unsigned int);
8302       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8303       sockflagsize = fdoff + 2;
8304     }
8305     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8306       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8307   }
8308   return fp;
8309
8310 }
8311 /*}}}*/
8312
8313
8314 /*
8315  * Clear the corresponding bit when the (possibly) socket stream is closed.
8316  * There still a small hole: we miss an implicit close which might occur
8317  * via freopen().  >> Todo
8318  */
8319 /*{{{ int my_fclose(FILE *fp)*/
8320 int my_fclose(FILE *fp) {
8321   if (fp) {
8322     unsigned int fd = fileno(fp);
8323     unsigned int fdoff = fd / sizeof(unsigned int);
8324
8325     if (sockflagsize && fdoff <= sockflagsize)
8326       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8327   }
8328   return fclose(fp);
8329 }
8330 /*}}}*/
8331
8332
8333 /*
8334  * A simple fwrite replacement which outputs itmsz*nitm chars without
8335  * introducing record boundaries every itmsz chars.
8336  * We are using fputs, which depends on a terminating null.  We may
8337  * well be writing binary data, so we need to accommodate not only
8338  * data with nulls sprinkled in the middle but also data with no null
8339  * byte at the end.
8340  */
8341 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8342 int
8343 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8344 {
8345   register char *cp, *end, *cpd, *data;
8346   register unsigned int fd = fileno(dest);
8347   register unsigned int fdoff = fd / sizeof(unsigned int);
8348   int retval;
8349   int bufsize = itmsz * nitm + 1;
8350
8351   if (fdoff < sockflagsize &&
8352       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8353     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8354     return nitm;
8355   }
8356
8357   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8358   memcpy( data, src, itmsz*nitm );
8359   data[itmsz*nitm] = '\0';
8360
8361   end = data + itmsz * nitm;
8362   retval = (int) nitm; /* on success return # items written */
8363
8364   cpd = data;
8365   while (cpd <= end) {
8366     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8367     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8368     if (cp < end)
8369       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8370     cpd = cp + 1;
8371   }
8372
8373   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8374   return retval;
8375
8376 }  /* end of my_fwrite() */
8377 /*}}}*/
8378
8379 /*{{{ int my_flush(FILE *fp)*/
8380 int
8381 Perl_my_flush(pTHX_ FILE *fp)
8382 {
8383     int res;
8384     if ((res = fflush(fp)) == 0 && fp) {
8385 #ifdef VMS_DO_SOCKETS
8386         Stat_t s;
8387         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8388 #endif
8389             res = fsync(fileno(fp));
8390     }
8391 /*
8392  * If the flush succeeded but set end-of-file, we need to clear
8393  * the error because our caller may check ferror().  BTW, this
8394  * probably means we just flushed an empty file.
8395  */
8396     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8397
8398     return res;
8399 }
8400 /*}}}*/
8401
8402 /*
8403  * Here are replacements for the following Unix routines in the VMS environment:
8404  *      getpwuid    Get information for a particular UIC or UID
8405  *      getpwnam    Get information for a named user
8406  *      getpwent    Get information for each user in the rights database
8407  *      setpwent    Reset search to the start of the rights database
8408  *      endpwent    Finish searching for users in the rights database
8409  *
8410  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8411  * (defined in pwd.h), which contains the following fields:-
8412  *      struct passwd {
8413  *              char        *pw_name;    Username (in lower case)
8414  *              char        *pw_passwd;  Hashed password
8415  *              unsigned int pw_uid;     UIC
8416  *              unsigned int pw_gid;     UIC group  number
8417  *              char        *pw_unixdir; Default device/directory (VMS-style)
8418  *              char        *pw_gecos;   Owner name
8419  *              char        *pw_dir;     Default device/directory (Unix-style)
8420  *              char        *pw_shell;   Default CLI name (eg. DCL)
8421  *      };
8422  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8423  *
8424  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8425  * not the UIC member number (eg. what's returned by getuid()),
8426  * getpwuid() can accept either as input (if uid is specified, the caller's
8427  * UIC group is used), though it won't recognise gid=0.
8428  *
8429  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8430  * information about other users in your group or in other groups, respectively.
8431  * If the required privilege is not available, then these routines fill only
8432  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8433  * string).
8434  *
8435  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8436  */
8437
8438 /* sizes of various UAF record fields */
8439 #define UAI$S_USERNAME 12
8440 #define UAI$S_IDENT    31
8441 #define UAI$S_OWNER    31
8442 #define UAI$S_DEFDEV   31
8443 #define UAI$S_DEFDIR   63
8444 #define UAI$S_DEFCLI   31
8445 #define UAI$S_PWD       8
8446
8447 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8448                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8449                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8450
8451 static char __empty[]= "";
8452 static struct passwd __passwd_empty=
8453     {(char *) __empty, (char *) __empty, 0, 0,
8454      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8455 static int contxt= 0;
8456 static struct passwd __pwdcache;
8457 static char __pw_namecache[UAI$S_IDENT+1];
8458
8459 /*
8460  * This routine does most of the work extracting the user information.
8461  */
8462 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8463 {
8464     static struct {
8465         unsigned char length;
8466         char pw_gecos[UAI$S_OWNER+1];
8467     } owner;
8468     static union uicdef uic;
8469     static struct {
8470         unsigned char length;
8471         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8472     } defdev;
8473     static struct {
8474         unsigned char length;
8475         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8476     } defdir;
8477     static struct {
8478         unsigned char length;
8479         char pw_shell[UAI$S_DEFCLI+1];
8480     } defcli;
8481     static char pw_passwd[UAI$S_PWD+1];
8482
8483     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8484     struct dsc$descriptor_s name_desc;
8485     unsigned long int sts;
8486
8487     static struct itmlst_3 itmlst[]= {
8488         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8489         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8490         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8491         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8492         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8493         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8494         {0,                0,           NULL,    NULL}};
8495
8496     name_desc.dsc$w_length=  strlen(name);
8497     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8498     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8499     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8500
8501 /*  Note that sys$getuai returns many fields as counted strings. */
8502     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8503     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8504       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8505     }
8506     else { _ckvmssts(sts); }
8507     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8508
8509     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8510     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8511     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8512     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8513     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8514     owner.pw_gecos[lowner]=            '\0';
8515     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8516     defcli.pw_shell[ldefcli]=          '\0';
8517     if (valid_uic(uic)) {
8518         pwd->pw_uid= uic.uic$l_uic;
8519         pwd->pw_gid= uic.uic$v_group;
8520     }
8521     else
8522       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8523     pwd->pw_passwd=  pw_passwd;
8524     pwd->pw_gecos=   owner.pw_gecos;
8525     pwd->pw_dir=     defdev.pw_dir;
8526     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8527     pwd->pw_shell=   defcli.pw_shell;
8528     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8529         int ldir;
8530         ldir= strlen(pwd->pw_unixdir) - 1;
8531         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8532     }
8533     else
8534         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8535     if (!decc_efs_case_preserve)
8536         __mystrtolower(pwd->pw_unixdir);
8537     return 1;
8538 }
8539
8540 /*
8541  * Get information for a named user.
8542 */
8543 /*{{{struct passwd *getpwnam(char *name)*/
8544 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8545 {
8546     struct dsc$descriptor_s name_desc;
8547     union uicdef uic;
8548     unsigned long int status, sts;
8549
8550     __pwdcache = __passwd_empty;
8551     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8552       /* We still may be able to determine pw_uid and pw_gid */
8553       name_desc.dsc$w_length=  strlen(name);
8554       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8555       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8556       name_desc.dsc$a_pointer= (char *) name;
8557       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8558         __pwdcache.pw_uid= uic.uic$l_uic;
8559         __pwdcache.pw_gid= uic.uic$v_group;
8560       }
8561       else {
8562         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8563           set_vaxc_errno(sts);
8564           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8565           return NULL;
8566         }
8567         else { _ckvmssts(sts); }
8568       }
8569     }
8570     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8571     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8572     __pwdcache.pw_name= __pw_namecache;
8573     return &__pwdcache;
8574 }  /* end of my_getpwnam() */
8575 /*}}}*/
8576
8577 /*
8578  * Get information for a particular UIC or UID.
8579  * Called by my_getpwent with uid=-1 to list all users.
8580 */
8581 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8582 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8583 {
8584     const $DESCRIPTOR(name_desc,__pw_namecache);
8585     unsigned short lname;
8586     union uicdef uic;
8587     unsigned long int status;
8588
8589     if (uid == (unsigned int) -1) {
8590       do {
8591         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8592         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8593           set_vaxc_errno(status);
8594           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8595           my_endpwent();
8596           return NULL;
8597         }
8598         else { _ckvmssts(status); }
8599       } while (!valid_uic (uic));
8600     }
8601     else {
8602       uic.uic$l_uic= uid;
8603       if (!uic.uic$v_group)
8604         uic.uic$v_group= PerlProc_getgid();
8605       if (valid_uic(uic))
8606         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8607       else status = SS$_IVIDENT;
8608       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8609           status == RMS$_PRV) {
8610         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8611         return NULL;
8612       }
8613       else { _ckvmssts(status); }
8614     }
8615     __pw_namecache[lname]= '\0';
8616     __mystrtolower(__pw_namecache);
8617
8618     __pwdcache = __passwd_empty;
8619     __pwdcache.pw_name = __pw_namecache;
8620
8621 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8622     The identifier's value is usually the UIC, but it doesn't have to be,
8623     so if we can, we let fillpasswd update this. */
8624     __pwdcache.pw_uid =  uic.uic$l_uic;
8625     __pwdcache.pw_gid =  uic.uic$v_group;
8626
8627     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8628     return &__pwdcache;
8629
8630 }  /* end of my_getpwuid() */
8631 /*}}}*/
8632
8633 /*
8634  * Get information for next user.
8635 */
8636 /*{{{struct passwd *my_getpwent()*/
8637 struct passwd *Perl_my_getpwent(pTHX)
8638 {
8639     return (my_getpwuid((unsigned int) -1));
8640 }
8641 /*}}}*/
8642
8643 /*
8644  * Finish searching rights database for users.
8645 */
8646 /*{{{void my_endpwent()*/
8647 void Perl_my_endpwent(pTHX)
8648 {
8649     if (contxt) {
8650       _ckvmssts(sys$finish_rdb(&contxt));
8651       contxt= 0;
8652     }
8653 }
8654 /*}}}*/
8655
8656 #ifdef HOMEGROWN_POSIX_SIGNALS
8657   /* Signal handling routines, pulled into the core from POSIX.xs.
8658    *
8659    * We need these for threads, so they've been rolled into the core,
8660    * rather than left in POSIX.xs.
8661    *
8662    * (DRS, Oct 23, 1997)
8663    */
8664
8665   /* sigset_t is atomic under VMS, so these routines are easy */
8666 /*{{{int my_sigemptyset(sigset_t *) */
8667 int my_sigemptyset(sigset_t *set) {
8668     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8669     *set = 0; return 0;
8670 }
8671 /*}}}*/
8672
8673
8674 /*{{{int my_sigfillset(sigset_t *)*/
8675 int my_sigfillset(sigset_t *set) {
8676     int i;
8677     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8678     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8679     return 0;
8680 }
8681 /*}}}*/
8682
8683
8684 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8685 int my_sigaddset(sigset_t *set, int sig) {
8686     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8687     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8688     *set |= (1 << (sig - 1));
8689     return 0;
8690 }
8691 /*}}}*/
8692
8693
8694 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8695 int my_sigdelset(sigset_t *set, int sig) {
8696     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8697     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8698     *set &= ~(1 << (sig - 1));
8699     return 0;
8700 }
8701 /*}}}*/
8702
8703
8704 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8705 int my_sigismember(sigset_t *set, int sig) {
8706     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8707     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8708     return *set & (1 << (sig - 1));
8709 }
8710 /*}}}*/
8711
8712
8713 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8714 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8715     sigset_t tempmask;
8716
8717     /* If set and oset are both null, then things are badly wrong. Bail out. */
8718     if ((oset == NULL) && (set == NULL)) {
8719       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8720       return -1;
8721     }
8722
8723     /* If set's null, then we're just handling a fetch. */
8724     if (set == NULL) {
8725         tempmask = sigblock(0);
8726     }
8727     else {
8728       switch (how) {
8729       case SIG_SETMASK:
8730         tempmask = sigsetmask(*set);
8731         break;
8732       case SIG_BLOCK:
8733         tempmask = sigblock(*set);
8734         break;
8735       case SIG_UNBLOCK:
8736         tempmask = sigblock(0);
8737         sigsetmask(*oset & ~tempmask);
8738         break;
8739       default:
8740         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8741         return -1;
8742       }
8743     }
8744
8745     /* Did they pass us an oset? If so, stick our holding mask into it */
8746     if (oset)
8747       *oset = tempmask;
8748
8749     return 0;
8750 }
8751 /*}}}*/
8752 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8753
8754
8755 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8756  * my_utime(), and flex_stat(), all of which operate on UTC unless
8757  * VMSISH_TIMES is true.
8758  */
8759 /* method used to handle UTC conversions:
8760  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8761  */
8762 static int gmtime_emulation_type;
8763 /* number of secs to add to UTC POSIX-style time to get local time */
8764 static long int utc_offset_secs;
8765
8766 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8767  * in vmsish.h.  #undef them here so we can call the CRTL routines
8768  * directly.
8769  */
8770 #undef gmtime
8771 #undef localtime
8772 #undef time
8773
8774
8775 /*
8776  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8777  * qualifier with the extern prefix pragma.  This provisional
8778  * hack circumvents this prefix pragma problem in previous
8779  * precompilers.
8780  */
8781 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8782 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8783 #    pragma __extern_prefix save
8784 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8785 #    define gmtime decc$__utctz_gmtime
8786 #    define localtime decc$__utctz_localtime
8787 #    define time decc$__utc_time
8788 #    pragma __extern_prefix restore
8789
8790      struct tm *gmtime(), *localtime();
8791
8792 #  endif
8793 #endif
8794
8795
8796 static time_t toutc_dst(time_t loc) {
8797   struct tm *rsltmp;
8798
8799   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8800   loc -= utc_offset_secs;
8801   if (rsltmp->tm_isdst) loc -= 3600;
8802   return loc;
8803 }
8804 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8805        ((gmtime_emulation_type || my_time(NULL)), \
8806        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8807        ((secs) - utc_offset_secs))))
8808
8809 static time_t toloc_dst(time_t utc) {
8810   struct tm *rsltmp;
8811
8812   utc += utc_offset_secs;
8813   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8814   if (rsltmp->tm_isdst) utc += 3600;
8815   return utc;
8816 }
8817 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8818        ((gmtime_emulation_type || my_time(NULL)), \
8819        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8820        ((secs) + utc_offset_secs))))
8821
8822 #ifndef RTL_USES_UTC
8823 /*
8824
8825     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8826         DST starts on 1st sun of april      at 02:00  std time
8827             ends on last sun of october     at 02:00  dst time
8828     see the UCX management command reference, SET CONFIG TIMEZONE
8829     for formatting info.
8830
8831     No, it's not as general as it should be, but then again, NOTHING
8832     will handle UK times in a sensible way.
8833 */
8834
8835
8836 /*
8837     parse the DST start/end info:
8838     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8839 */
8840
8841 static char *
8842 tz_parse_startend(char *s, struct tm *w, int *past)
8843 {
8844     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8845     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8846     time_t g;
8847
8848     if (!s)    return 0;
8849     if (!w) return 0;
8850     if (!past) return 0;
8851
8852     ly = 0;
8853     if (w->tm_year % 4        == 0) ly = 1;
8854     if (w->tm_year % 100      == 0) ly = 0;
8855     if (w->tm_year+1900 % 400 == 0) ly = 1;
8856     if (ly) dinm[1]++;
8857
8858     dozjd = isdigit(*s);
8859     if (*s == 'J' || *s == 'j' || dozjd) {
8860         if (!dozjd && !isdigit(*++s)) return 0;
8861         d = *s++ - '0';
8862         if (isdigit(*s)) {
8863             d = d*10 + *s++ - '0';
8864             if (isdigit(*s)) {
8865                 d = d*10 + *s++ - '0';
8866             }
8867         }
8868         if (d == 0) return 0;
8869         if (d > 366) return 0;
8870         d--;
8871         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8872         g = d * 86400;
8873         dozjd = 1;
8874     } else if (*s == 'M' || *s == 'm') {
8875         if (!isdigit(*++s)) return 0;
8876         m = *s++ - '0';
8877         if (isdigit(*s)) m = 10*m + *s++ - '0';
8878         if (*s != '.') return 0;
8879         if (!isdigit(*++s)) return 0;
8880         n = *s++ - '0';
8881         if (n < 1 || n > 5) return 0;
8882         if (*s != '.') return 0;
8883         if (!isdigit(*++s)) return 0;
8884         d = *s++ - '0';
8885         if (d > 6) return 0;
8886     }
8887
8888     if (*s == '/') {
8889         if (!isdigit(*++s)) return 0;
8890         hour = *s++ - '0';
8891         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8892         if (*s == ':') {
8893             if (!isdigit(*++s)) return 0;
8894             min = *s++ - '0';
8895             if (isdigit(*s)) min = 10*min + *s++ - '0';
8896             if (*s == ':') {
8897                 if (!isdigit(*++s)) return 0;
8898                 sec = *s++ - '0';
8899                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8900             }
8901         }
8902     } else {
8903         hour = 2;
8904         min = 0;
8905         sec = 0;
8906     }
8907
8908     if (dozjd) {
8909         if (w->tm_yday < d) goto before;
8910         if (w->tm_yday > d) goto after;
8911     } else {
8912         if (w->tm_mon+1 < m) goto before;
8913         if (w->tm_mon+1 > m) goto after;
8914
8915         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8916         k = d - j; /* mday of first d */
8917         if (k <= 0) k += 7;
8918         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8919         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8920         if (w->tm_mday < k) goto before;
8921         if (w->tm_mday > k) goto after;
8922     }
8923
8924     if (w->tm_hour < hour) goto before;
8925     if (w->tm_hour > hour) goto after;
8926     if (w->tm_min  < min)  goto before;
8927     if (w->tm_min  > min)  goto after;
8928     if (w->tm_sec  < sec)  goto before;
8929     goto after;
8930
8931 before:
8932     *past = 0;
8933     return s;
8934 after:
8935     *past = 1;
8936     return s;
8937 }
8938
8939
8940
8941
8942 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8943
8944 static char *
8945 tz_parse_offset(char *s, int *offset)
8946 {
8947     int hour = 0, min = 0, sec = 0;
8948     int neg = 0;
8949     if (!s) return 0;
8950     if (!offset) return 0;
8951
8952     if (*s == '-') {neg++; s++;}
8953     if (*s == '+') s++;
8954     if (!isdigit(*s)) return 0;
8955     hour = *s++ - '0';
8956     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8957     if (hour > 24) return 0;
8958     if (*s == ':') {
8959         if (!isdigit(*++s)) return 0;
8960         min = *s++ - '0';
8961         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8962         if (min > 59) return 0;
8963         if (*s == ':') {
8964             if (!isdigit(*++s)) return 0;
8965             sec = *s++ - '0';
8966             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8967             if (sec > 59) return 0;
8968         }
8969     }
8970
8971     *offset = (hour*60+min)*60 + sec;
8972     if (neg) *offset = -*offset;
8973     return s;
8974 }
8975
8976 /*
8977     input time is w, whatever type of time the CRTL localtime() uses.
8978     sets dst, the zone, and the gmtoff (seconds)
8979
8980     caches the value of TZ and UCX$TZ env variables; note that
8981     my_setenv looks for these and sets a flag if they're changed
8982     for efficiency.
8983
8984     We have to watch out for the "australian" case (dst starts in
8985     october, ends in april)...flagged by "reverse" and checked by
8986     scanning through the months of the previous year.
8987
8988 */
8989
8990 static int
8991 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8992 {
8993     time_t when;
8994     struct tm *w2;
8995     char *s,*s2;
8996     char *dstzone, *tz, *s_start, *s_end;
8997     int std_off, dst_off, isdst;
8998     int y, dststart, dstend;
8999     static char envtz[1025];  /* longer than any logical, symbol, ... */
9000     static char ucxtz[1025];
9001     static char reversed = 0;
9002
9003     if (!w) return 0;
9004
9005     if (tz_updated) {
9006         tz_updated = 0;
9007         reversed = -1;  /* flag need to check  */
9008         envtz[0] = ucxtz[0] = '\0';
9009         tz = my_getenv("TZ",0);
9010         if (tz) strcpy(envtz, tz);
9011         tz = my_getenv("UCX$TZ",0);
9012         if (tz) strcpy(ucxtz, tz);
9013         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9014     }
9015     tz = envtz;
9016     if (!*tz) tz = ucxtz;
9017
9018     s = tz;
9019     while (isalpha(*s)) s++;
9020     s = tz_parse_offset(s, &std_off);
9021     if (!s) return 0;
9022     if (!*s) {                  /* no DST, hurray we're done! */
9023         isdst = 0;
9024         goto done;
9025     }
9026
9027     dstzone = s;
9028     while (isalpha(*s)) s++;
9029     s2 = tz_parse_offset(s, &dst_off);
9030     if (s2) {
9031         s = s2;
9032     } else {
9033         dst_off = std_off - 3600;
9034     }
9035
9036     if (!*s) {      /* default dst start/end?? */
9037         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9038             s = strchr(ucxtz,',');
9039         }
9040         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9041     }
9042     if (*s != ',') return 0;
9043
9044     when = *w;
9045     when = _toutc(when);      /* convert to utc */
9046     when = when - std_off;    /* convert to pseudolocal time*/
9047
9048     w2 = localtime(&when);
9049     y = w2->tm_year;
9050     s_start = s+1;
9051     s = tz_parse_startend(s_start,w2,&dststart);
9052     if (!s) return 0;
9053     if (*s != ',') return 0;
9054
9055     when = *w;
9056     when = _toutc(when);      /* convert to utc */
9057     when = when - dst_off;    /* convert to pseudolocal time*/
9058     w2 = localtime(&when);
9059     if (w2->tm_year != y) {   /* spans a year, just check one time */
9060         when += dst_off - std_off;
9061         w2 = localtime(&when);
9062     }
9063     s_end = s+1;
9064     s = tz_parse_startend(s_end,w2,&dstend);
9065     if (!s) return 0;
9066
9067     if (reversed == -1) {  /* need to check if start later than end */
9068         int j, ds, de;
9069
9070         when = *w;
9071         if (when < 2*365*86400) {
9072             when += 2*365*86400;
9073         } else {
9074             when -= 365*86400;
9075         }
9076         w2 =localtime(&when);
9077         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9078
9079         for (j = 0; j < 12; j++) {
9080             w2 =localtime(&when);
9081             tz_parse_startend(s_start,w2,&ds);
9082             tz_parse_startend(s_end,w2,&de);
9083             if (ds != de) break;
9084             when += 30*86400;
9085         }
9086         reversed = 0;
9087         if (de && !ds) reversed = 1;
9088     }
9089
9090     isdst = dststart && !dstend;
9091     if (reversed) isdst = dststart  || !dstend;
9092
9093 done:
9094     if (dst)    *dst = isdst;
9095     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9096     if (isdst)  tz = dstzone;
9097     if (zone) {
9098         while(isalpha(*tz))  *zone++ = *tz++;
9099         *zone = '\0';
9100     }
9101     return 1;
9102 }
9103
9104 #endif /* !RTL_USES_UTC */
9105
9106 /* my_time(), my_localtime(), my_gmtime()
9107  * By default traffic in UTC time values, using CRTL gmtime() or
9108  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9109  * Note: We need to use these functions even when the CRTL has working
9110  * UTC support, since they also handle C<use vmsish qw(times);>
9111  *
9112  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9113  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9114  */
9115
9116 /*{{{time_t my_time(time_t *timep)*/
9117 time_t Perl_my_time(pTHX_ time_t *timep)
9118 {
9119   time_t when;
9120   struct tm *tm_p;
9121
9122   if (gmtime_emulation_type == 0) {
9123     int dstnow;
9124     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9125                               /* results of calls to gmtime() and localtime() */
9126                               /* for same &base */
9127
9128     gmtime_emulation_type++;
9129     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9130       char off[LNM$C_NAMLENGTH+1];;
9131
9132       gmtime_emulation_type++;
9133       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9134         gmtime_emulation_type++;
9135         utc_offset_secs = 0;
9136         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9137       }
9138       else { utc_offset_secs = atol(off); }
9139     }
9140     else { /* We've got a working gmtime() */
9141       struct tm gmt, local;
9142
9143       gmt = *tm_p;
9144       tm_p = localtime(&base);
9145       local = *tm_p;
9146       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9147       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9148       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9149       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9150     }
9151   }
9152
9153   when = time(NULL);
9154 # ifdef VMSISH_TIME
9155 # ifdef RTL_USES_UTC
9156   if (VMSISH_TIME) when = _toloc(when);
9157 # else
9158   if (!VMSISH_TIME) when = _toutc(when);
9159 # endif
9160 # endif
9161   if (timep != NULL) *timep = when;
9162   return when;
9163
9164 }  /* end of my_time() */
9165 /*}}}*/
9166
9167
9168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9169 struct tm *
9170 Perl_my_gmtime(pTHX_ const time_t *timep)
9171 {
9172   char *p;
9173   time_t when;
9174   struct tm *rsltmp;
9175
9176   if (timep == NULL) {
9177     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9178     return NULL;
9179   }
9180   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9181
9182   when = *timep;
9183 # ifdef VMSISH_TIME
9184   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9185 #  endif
9186 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9187   return gmtime(&when);
9188 # else
9189   /* CRTL localtime() wants local time as input, so does no tz correction */
9190   rsltmp = localtime(&when);
9191   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9192   return rsltmp;
9193 #endif
9194 }  /* end of my_gmtime() */
9195 /*}}}*/
9196
9197
9198 /*{{{struct tm *my_localtime(const time_t *timep)*/
9199 struct tm *
9200 Perl_my_localtime(pTHX_ const time_t *timep)
9201 {
9202   time_t when, whenutc;
9203   struct tm *rsltmp;
9204   int dst, offset;
9205
9206   if (timep == NULL) {
9207     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9208     return NULL;
9209   }
9210   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9211   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9212
9213   when = *timep;
9214 # ifdef RTL_USES_UTC
9215 # ifdef VMSISH_TIME
9216   if (VMSISH_TIME) when = _toutc(when);
9217 # endif
9218   /* CRTL localtime() wants UTC as input, does tz correction itself */
9219   return localtime(&when);
9220
9221 # else /* !RTL_USES_UTC */
9222   whenutc = when;
9223 # ifdef VMSISH_TIME
9224   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9225   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9226 # endif
9227   dst = -1;
9228 #ifndef RTL_USES_UTC
9229   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9230       when = whenutc - offset;                   /* pseudolocal time*/
9231   }
9232 # endif
9233   /* CRTL localtime() wants local time as input, so does no tz correction */
9234   rsltmp = localtime(&when);
9235   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9236   return rsltmp;
9237 # endif
9238
9239 } /*  end of my_localtime() */
9240 /*}}}*/
9241
9242 /* Reset definitions for later calls */
9243 #define gmtime(t)    my_gmtime(t)
9244 #define localtime(t) my_localtime(t)
9245 #define time(t)      my_time(t)
9246
9247
9248 /* my_utime - update modification time of a file
9249  * calling sequence is identical to POSIX utime(), but under
9250  * VMS only the modification time is changed; ODS-2 does not
9251  * maintain access times.  Restrictions differ from the POSIX
9252  * definition in that the time can be changed as long as the
9253  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9254  * no separate checks are made to insure that the caller is the
9255  * owner of the file or has special privs enabled.
9256  * Code here is based on Joe Meadows' FILE utility.
9257  */
9258
9259 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9260  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9261  * in 100 ns intervals.
9262  */
9263 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9264
9265 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9266 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9267 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9268 {
9269     return utime(file, utimes);
9270 }
9271 #else
9272 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9273 {
9274   register int i;
9275   int sts;
9276   long int bintime[2], len = 2, lowbit, unixtime,
9277            secscale = 10000000; /* seconds --> 100 ns intervals */
9278   unsigned long int chan, iosb[2], retsts;
9279   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9280   struct FAB myfab = cc$rms_fab;
9281   struct NAM mynam = cc$rms_nam;
9282 #if defined (__DECC) && defined (__VAX)
9283   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9284    * at least through VMS V6.1, which causes a type-conversion warning.
9285    */
9286 #  pragma message save
9287 #  pragma message disable cvtdiftypes
9288 #endif
9289   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9290   struct fibdef myfib;
9291 #if defined (__DECC) && defined (__VAX)
9292   /* This should be right after the declaration of myatr, but due
9293    * to a bug in VAX DEC C, this takes effect a statement early.
9294    */
9295 #  pragma message restore
9296 #endif
9297   /* cast ok for read only parameter */
9298   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9299                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9300                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9301
9302   if (file == NULL || *file == '\0') {
9303     set_errno(ENOENT);
9304     set_vaxc_errno(LIB$_INVARG);
9305     return -1;
9306   }
9307   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9308
9309   if (utimes != NULL) {
9310     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9311      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9312      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9313      * as input, we force the sign bit to be clear by shifting unixtime right
9314      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9315      */
9316     lowbit = (utimes->modtime & 1) ? secscale : 0;
9317     unixtime = (long int) utimes->modtime;
9318 #   ifdef VMSISH_TIME
9319     /* If input was UTC; convert to local for sys svc */
9320     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9321 #   endif
9322     unixtime >>= 1;  secscale <<= 1;
9323     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9324     if (!(retsts & 1)) {
9325       set_errno(EVMSERR);
9326       set_vaxc_errno(retsts);
9327       return -1;
9328     }
9329     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9330     if (!(retsts & 1)) {
9331       set_errno(EVMSERR);
9332       set_vaxc_errno(retsts);
9333       return -1;
9334     }
9335   }
9336   else {
9337     /* Just get the current time in VMS format directly */
9338     retsts = sys$gettim(bintime);
9339     if (!(retsts & 1)) {
9340       set_errno(EVMSERR);
9341       set_vaxc_errno(retsts);
9342       return -1;
9343     }
9344   }
9345
9346   myfab.fab$l_fna = vmsspec;
9347   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9348   myfab.fab$l_nam = &mynam;
9349   mynam.nam$l_esa = esa;
9350   mynam.nam$b_ess = (unsigned char) sizeof esa;
9351   mynam.nam$l_rsa = rsa;
9352   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9353   if (decc_efs_case_preserve)
9354       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9355
9356   /* Look for the file to be affected, letting RMS parse the file
9357    * specification for us as well.  I have set errno using only
9358    * values documented in the utime() man page for VMS POSIX.
9359    */
9360   retsts = sys$parse(&myfab,0,0);
9361   if (!(retsts & 1)) {
9362     set_vaxc_errno(retsts);
9363     if      (retsts == RMS$_PRV) set_errno(EACCES);
9364     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9365     else                         set_errno(EVMSERR);
9366     return -1;
9367   }
9368   retsts = sys$search(&myfab,0,0);
9369   if (!(retsts & 1)) {
9370     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9371     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9372     set_vaxc_errno(retsts);
9373     if      (retsts == RMS$_PRV) set_errno(EACCES);
9374     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9375     else                         set_errno(EVMSERR);
9376     return -1;
9377   }
9378
9379   devdsc.dsc$w_length = mynam.nam$b_dev;
9380   /* cast ok for read only parameter */
9381   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9382
9383   retsts = sys$assign(&devdsc,&chan,0,0);
9384   if (!(retsts & 1)) {
9385     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9386     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9387     set_vaxc_errno(retsts);
9388     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9389     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9390     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9391     else                               set_errno(EVMSERR);
9392     return -1;
9393   }
9394
9395   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9396   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9397
9398   memset((void *) &myfib, 0, sizeof myfib);
9399 #if defined(__DECC) || defined(__DECCXX)
9400   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9401   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9402   /* This prevents the revision time of the file being reset to the current
9403    * time as a result of our IO$_MODIFY $QIO. */
9404   myfib.fib$l_acctl = FIB$M_NORECORD;
9405 #else
9406   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9407   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9408   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9409 #endif
9410   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9411   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9412   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9413   _ckvmssts(sys$dassgn(chan));
9414   if (retsts & 1) retsts = iosb[0];
9415   if (!(retsts & 1)) {
9416     set_vaxc_errno(retsts);
9417     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9418     else                      set_errno(EVMSERR);
9419     return -1;
9420   }
9421
9422   return 0;
9423 }  /* end of my_utime() */
9424 #endif
9425 /*}}}*/
9426
9427 /*
9428  * flex_stat, flex_lstat, flex_fstat
9429  * basic stat, but gets it right when asked to stat
9430  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9431  */
9432
9433 #ifndef _USE_STD_STAT
9434 /* encode_dev packs a VMS device name string into an integer to allow
9435  * simple comparisons. This can be used, for example, to check whether two
9436  * files are located on the same device, by comparing their encoded device
9437  * names. Even a string comparison would not do, because stat() reuses the
9438  * device name buffer for each call; so without encode_dev, it would be
9439  * necessary to save the buffer and use strcmp (this would mean a number of
9440  * changes to the standard Perl code, to say nothing of what a Perl script
9441  * would have to do.
9442  *
9443  * The device lock id, if it exists, should be unique (unless perhaps compared
9444  * with lock ids transferred from other nodes). We have a lock id if the disk is
9445  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9446  * device names. Thus we use the lock id in preference, and only if that isn't
9447  * available, do we try to pack the device name into an integer (flagged by
9448  * the sign bit (LOCKID_MASK) being set).
9449  *
9450  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9451  * name and its encoded form, but it seems very unlikely that we will find
9452  * two files on different disks that share the same encoded device names,
9453  * and even more remote that they will share the same file id (if the test
9454  * is to check for the same file).
9455  *
9456  * A better method might be to use sys$device_scan on the first call, and to
9457  * search for the device, returning an index into the cached array.
9458  * The number returned would be more intelligable.
9459  * This is probably not worth it, and anyway would take quite a bit longer
9460  * on the first call.
9461  */
9462 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9463 static mydev_t encode_dev (pTHX_ const char *dev)
9464 {
9465   int i;
9466   unsigned long int f;
9467   mydev_t enc;
9468   char c;
9469   const char *q;
9470
9471   if (!dev || !dev[0]) return 0;
9472
9473 #if LOCKID_MASK
9474   {
9475     struct dsc$descriptor_s dev_desc;
9476     unsigned long int status, lockid, item = DVI$_LOCKID;
9477
9478     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9479        can try that first. */
9480     dev_desc.dsc$w_length =  strlen (dev);
9481     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9482     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9483     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9484     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9485     if (lockid) return (lockid & ~LOCKID_MASK);
9486   }
9487 #endif
9488
9489   /* Otherwise we try to encode the device name */
9490   enc = 0;
9491   f = 1;
9492   i = 0;
9493   for (q = dev + strlen(dev); q--; q >= dev) {
9494     if (isdigit (*q))
9495       c= (*q) - '0';
9496     else if (isalpha (toupper (*q)))
9497       c= toupper (*q) - 'A' + (char)10;
9498     else
9499       continue; /* Skip '$'s */
9500     i++;
9501     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9502     if (i>1) f *= 36;
9503     enc += f * (unsigned long int) c;
9504   }
9505   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9506
9507 }  /* end of encode_dev() */
9508 #endif
9509
9510 static char namecache[NAM$C_MAXRSS+1];
9511
9512 static int
9513 is_null_device(name)
9514     const char *name;
9515 {
9516   if (decc_bug_devnull != 0) {
9517     if (strcmp("/dev/null", name) == 0) /* temp hack */
9518       return 1;
9519   }
9520     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9521        The underscore prefix, controller letter, and unit number are
9522        independently optional; for our purposes, the colon punctuation
9523        is not.  The colon can be trailed by optional directory and/or
9524        filename, but two consecutive colons indicates a nodename rather
9525        than a device.  [pr]  */
9526   if (*name == '_') ++name;
9527   if (tolower(*name++) != 'n') return 0;
9528   if (tolower(*name++) != 'l') return 0;
9529   if (tolower(*name) == 'a') ++name;
9530   if (*name == '0') ++name;
9531   return (*name++ == ':') && (*name != ':');
9532 }
9533
9534 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9535 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9536  * subset of the applicable information.
9537  */
9538 bool
9539 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9540 {
9541   char fname_phdev[NAM$C_MAXRSS+1];
9542 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9543   /* Namecache not workable with symbolic links, as symbolic links do
9544    *  not have extensions and directories do in VMS mode.  So in order
9545    *  to test this, the did and ino_t must be used.
9546    *
9547    * Fix-me - Hide the information in the new stat structure
9548    *          Get rid of the namecache.
9549    */
9550   if (decc_posix_compliant_pathnames == 0)
9551 #endif
9552       if (statbufp == &PL_statcache)
9553           return cando_by_name(bit,effective,namecache);
9554   {
9555     char fname[NAM$C_MAXRSS+1];
9556     unsigned long int retsts;
9557     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9558                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9559
9560     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9561        device name on successive calls */
9562     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9563     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9564     namdsc.dsc$a_pointer = fname;
9565     namdsc.dsc$w_length = sizeof fname - 1;
9566
9567     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9568                              &namdsc,&namdsc.dsc$w_length,0,0);
9569     if (retsts & 1) {
9570       fname[namdsc.dsc$w_length] = '\0';
9571 /*
9572  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9573  * but if someone has redefined that logical, Perl gets very lost.  Since
9574  * we have the physical device name from the stat buffer, just paste it on.
9575  */
9576       strcpy( fname_phdev, statbufp->st_devnam );
9577       strcat( fname_phdev, strrchr(fname, ':') );
9578
9579       return cando_by_name(bit,effective,fname_phdev);
9580     }
9581     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9582       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9583       return FALSE;
9584     }
9585     _ckvmssts(retsts);
9586     return FALSE;  /* Should never get to here */
9587   }
9588 }  /* end of cando() */
9589 /*}}}*/
9590
9591
9592 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9593 I32
9594 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9595 {
9596   static char usrname[L_cuserid];
9597   static struct dsc$descriptor_s usrdsc =
9598          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9599   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9600   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9601   unsigned short int retlen, trnlnm_iter_count;
9602   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9603   union prvdef curprv;
9604   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9605          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9606   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9607          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9608          {0,0,0,0}};
9609   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9610          {0,0,0,0}};
9611   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9612
9613   if (!fname || !*fname) return FALSE;
9614   /* Make sure we expand logical names, since sys$check_access doesn't */
9615   if (!strpbrk(fname,"/]>:")) {
9616     strcpy(fileified,fname);
9617     trnlnm_iter_count = 0;
9618     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9619         trnlnm_iter_count++;
9620         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9621     }
9622     fname = fileified;
9623   }
9624   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9625   retlen = namdsc.dsc$w_length = strlen(vmsname);
9626   namdsc.dsc$a_pointer = vmsname;
9627   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9628       vmsname[retlen-1] == ':') {
9629     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9630     namdsc.dsc$w_length = strlen(fileified);
9631     namdsc.dsc$a_pointer = fileified;
9632   }
9633
9634   switch (bit) {
9635     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9636       access = ARM$M_EXECUTE; break;
9637     case S_IRUSR: case S_IRGRP: case S_IROTH:
9638       access = ARM$M_READ; break;
9639     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9640       access = ARM$M_WRITE; break;
9641     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9642       access = ARM$M_DELETE; break;
9643     default:
9644       return FALSE;
9645   }
9646
9647   /* Before we call $check_access, create a user profile with the current
9648    * process privs since otherwise it just uses the default privs from the
9649    * UAF and might give false positives or negatives.  This only works on
9650    * VMS versions v6.0 and later since that's when sys$create_user_profile
9651    * became available.
9652    */
9653
9654   /* get current process privs and username */
9655   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9656   _ckvmssts(iosb[0]);
9657
9658 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9659
9660   /* find out the space required for the profile */
9661   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9662                                     &usrprodsc.dsc$w_length,0));
9663
9664   /* allocate space for the profile and get it filled in */
9665   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9666   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9667                                     &usrprodsc.dsc$w_length,0));
9668
9669   /* use the profile to check access to the file; free profile & analyze results */
9670   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9671   Safefree(usrprodsc.dsc$a_pointer);
9672   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9673
9674 #else
9675
9676   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9677
9678 #endif
9679
9680   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9681       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9682       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9683     set_vaxc_errno(retsts);
9684     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9685     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9686     else set_errno(ENOENT);
9687     return FALSE;
9688   }
9689   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9690     return TRUE;
9691   }
9692   _ckvmssts(retsts);
9693
9694   return FALSE;  /* Should never get here */
9695
9696 }  /* end of cando_by_name() */
9697 /*}}}*/
9698
9699
9700 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9701 int
9702 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9703 {
9704   if (!fstat(fd,(stat_t *) statbufp)) {
9705     if (statbufp == (Stat_t *) &PL_statcache) {
9706     char *cptr;
9707
9708         /* Save name for cando by name in VMS format */
9709         cptr = getname(fd, namecache, 1);
9710
9711         /* This should not happen, but just in case */
9712         if (cptr == NULL)
9713            namecache[0] = '\0';
9714     }
9715 #ifdef _USE_STD_STAT
9716     memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9717 #else
9718     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9719 #endif
9720 #ifndef _USE_STD_STAT
9721     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9722     statbufp->st_devnam[63] = 0;
9723     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9724 #else
9725     /* todo:
9726      * The device is only encoded so that Perl_cando can use it to
9727      * look up ACLS.  So rmsexpand it to the 255 character version
9728      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9729      * for long filenames and symbolic links first.  This also seems
9730      * to remove the need for a namecache that could be stale.
9731      */
9732 #endif
9733
9734 #   ifdef RTL_USES_UTC
9735 #   ifdef VMSISH_TIME
9736     if (VMSISH_TIME) {
9737       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9738       statbufp->st_atime = _toloc(statbufp->st_atime);
9739       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9740     }
9741 #   endif
9742 #   else
9743 #   ifdef VMSISH_TIME
9744     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9745 #   else
9746     if (1) {
9747 #   endif
9748       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9749       statbufp->st_atime = _toutc(statbufp->st_atime);
9750       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9751     }
9752 #endif
9753     return 0;
9754   }
9755   return -1;
9756
9757 }  /* end of flex_fstat() */
9758 /*}}}*/
9759
9760 #if !defined(__VAX) && __CRTL_VER >= 80200000
9761 #ifdef lstat
9762 #undef lstat
9763 #endif
9764 #else
9765 #ifdef lstat
9766 #undef lstat
9767 #endif
9768 #define lstat(_x, _y) stat(_x, _y)
9769 #endif
9770
9771 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9772
9773 static int
9774 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9775 {
9776     char fileified[NAM$C_MAXRSS+1];
9777     char temp_fspec[NAM$C_MAXRSS+300];
9778     int retval = -1;
9779     int saved_errno, saved_vaxc_errno;
9780
9781     if (!fspec) return retval;
9782     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9783     strcpy(temp_fspec, fspec);
9784     if (statbufp == (Stat_t *) &PL_statcache)
9785       do_tovmsspec(temp_fspec,namecache,0);
9786     if (decc_bug_devnull != 0) {
9787       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9788         memset(statbufp,0,sizeof *statbufp);
9789         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9790         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9791         statbufp->st_uid = 0x00010001;
9792         statbufp->st_gid = 0x0001;
9793         time((time_t *)&statbufp->st_mtime);
9794         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9795         return 0;
9796       }
9797     }
9798
9799     /* Try for a directory name first.  If fspec contains a filename without
9800      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9801      * and sea:[wine.dark]water. exist, we prefer the directory here.
9802      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9803      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9804      * the file with null type, specify this by calling flex_stat() with
9805      * a '.' at the end of fspec.
9806      *
9807      * If we are in Posix filespec mode, accept the filename as is.
9808      */
9809 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9810   if (decc_posix_compliant_pathnames == 0) {
9811 #endif
9812     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9813       if (lstat_flag == 0)
9814         retval = stat(fileified,(stat_t *) statbufp);
9815       else
9816         retval = lstat(fileified,(stat_t *) statbufp);
9817       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9818         strcpy(namecache,fileified);
9819     }
9820     if (retval) {
9821       if (lstat_flag == 0)
9822         retval = stat(temp_fspec,(stat_t *) statbufp);
9823       else
9824         retval = lstat(temp_fspec,(stat_t *) statbufp);
9825     }
9826 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9827   } else {
9828     if (lstat_flag == 0)
9829       retval = stat(temp_fspec,(stat_t *) statbufp);
9830     else
9831       retval = lstat(temp_fspec,(stat_t *) statbufp);
9832   }
9833 #endif
9834     if (!retval) {
9835 #ifdef _USE_STD_STAT
9836       memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9837 #else
9838       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9839 #endif
9840 #ifndef _USE_STD_STAT
9841       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9842       statbufp->st_devnam[63] = 0;
9843       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9844 #else
9845     /* todo:
9846      * The device is only encoded so that Perl_cando can use it to
9847      * look up ACLS.  So rmsexpand it to the 255 character version
9848      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9849      * for long filenames and symbolic links first.  This also seems
9850      * to remove the need for a namecache that could be stale.
9851      */
9852 #endif
9853 #     ifdef RTL_USES_UTC
9854 #     ifdef VMSISH_TIME
9855       if (VMSISH_TIME) {
9856         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9857         statbufp->st_atime = _toloc(statbufp->st_atime);
9858         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9859       }
9860 #     endif
9861 #     else
9862 #     ifdef VMSISH_TIME
9863       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9864 #     else
9865       if (1) {
9866 #     endif
9867         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9868         statbufp->st_atime = _toutc(statbufp->st_atime);
9869         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9870       }
9871 #     endif
9872     }
9873     /* If we were successful, leave errno where we found it */
9874     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9875     return retval;
9876
9877 }  /* end of flex_stat_int() */
9878
9879
9880 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9881 int
9882 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9883 {
9884    return flex_stat_int(fspec, statbufp, 0);
9885 }
9886 /*}}}*/
9887
9888 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9889 int
9890 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9891 {
9892    return flex_stat_int(fspec, statbufp, 1);
9893 }
9894 /*}}}*/
9895
9896
9897 /*{{{char *my_getlogin()*/
9898 /* VMS cuserid == Unix getlogin, except calling sequence */
9899 char *
9900 my_getlogin(void)
9901 {
9902     static char user[L_cuserid];
9903     return cuserid(user);
9904 }
9905 /*}}}*/
9906
9907
9908 /*  rmscopy - copy a file using VMS RMS routines
9909  *
9910  *  Copies contents and attributes of spec_in to spec_out, except owner
9911  *  and protection information.  Name and type of spec_in are used as
9912  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9913  *  should try to propagate timestamps from the input file to the output file.
9914  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9915  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9916  *  propagated to the output file at creation iff the output file specification
9917  *  did not contain an explicit name or type, and the revision date is always
9918  *  updated at the end of the copy operation.  If it is greater than 0, then
9919  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9920  *  other than the revision date should be propagated, and bit 1 indicates
9921  *  that the revision date should be propagated.
9922  *
9923  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9924  *
9925  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9926  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9927  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9928  * as part of the Perl standard distribution under the terms of the
9929  * GNU General Public License or the Perl Artistic License.  Copies
9930  * of each may be found in the Perl standard distribution.
9931  */ /* FIXME */
9932 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9933 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9934 int
9935 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9936 {
9937     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9938          rsa[NAM$C_MAXRSS], ubf[32256];
9939     unsigned long int i, sts, sts2;
9940     struct FAB fab_in, fab_out;
9941     struct RAB rab_in, rab_out;
9942     struct NAM nam;
9943     struct XABDAT xabdat;
9944     struct XABFHC xabfhc;
9945     struct XABRDT xabrdt;
9946     struct XABSUM xabsum;
9947
9948     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9949         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9950       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9951       return 0;
9952     }
9953
9954     fab_in = cc$rms_fab;
9955     fab_in.fab$l_fna = vmsin;
9956     fab_in.fab$b_fns = strlen(vmsin);
9957     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9958     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9959     fab_in.fab$l_fop = FAB$M_SQO;
9960     fab_in.fab$l_nam =  &nam;
9961     fab_in.fab$l_xab = (void *) &xabdat;
9962
9963     nam = cc$rms_nam;
9964     nam.nam$l_rsa = rsa;
9965     nam.nam$b_rss = sizeof(rsa);
9966     nam.nam$l_esa = esa;
9967     nam.nam$b_ess = sizeof (esa);
9968     nam.nam$b_esl = nam.nam$b_rsl = 0;
9969 #ifdef NAM$M_NO_SHORT_UPCASE
9970     if (decc_efs_case_preserve)
9971         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9972 #endif
9973
9974     xabdat = cc$rms_xabdat;        /* To get creation date */
9975     xabdat.xab$l_nxt = (void *) &xabfhc;
9976
9977     xabfhc = cc$rms_xabfhc;        /* To get record length */
9978     xabfhc.xab$l_nxt = (void *) &xabsum;
9979
9980     xabsum = cc$rms_xabsum;        /* To get key and area information */
9981
9982     if (!((sts = sys$open(&fab_in)) & 1)) {
9983       set_vaxc_errno(sts);
9984       switch (sts) {
9985         case RMS$_FNF: case RMS$_DNF:
9986           set_errno(ENOENT); break;
9987         case RMS$_DIR:
9988           set_errno(ENOTDIR); break;
9989         case RMS$_DEV:
9990           set_errno(ENODEV); break;
9991         case RMS$_SYN:
9992           set_errno(EINVAL); break;
9993         case RMS$_PRV:
9994           set_errno(EACCES); break;
9995         default:
9996           set_errno(EVMSERR);
9997       }
9998       return 0;
9999     }
10000
10001     fab_out = fab_in;
10002     fab_out.fab$w_ifi = 0;
10003     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10004     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10005     fab_out.fab$l_fop = FAB$M_SQO;
10006     fab_out.fab$l_fna = vmsout;
10007     fab_out.fab$b_fns = strlen(vmsout);
10008     fab_out.fab$l_dna = nam.nam$l_name;
10009     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10010
10011     if (preserve_dates == 0) {  /* Act like DCL COPY */
10012       nam.nam$b_nop |= NAM$M_SYNCHK;
10013       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10014       if (!((sts = sys$parse(&fab_out)) & 1)) {
10015         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10016         set_vaxc_errno(sts);
10017         return 0;
10018       }
10019       fab_out.fab$l_xab = (void *) &xabdat;
10020       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10021     }
10022     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10023     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10024       preserve_dates =0;      /* bitmask from this point forward   */
10025
10026     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10027     if (!((sts = sys$create(&fab_out)) & 1)) {
10028       set_vaxc_errno(sts);
10029       switch (sts) {
10030         case RMS$_DNF:
10031           set_errno(ENOENT); break;
10032         case RMS$_DIR:
10033           set_errno(ENOTDIR); break;
10034         case RMS$_DEV:
10035           set_errno(ENODEV); break;
10036         case RMS$_SYN:
10037           set_errno(EINVAL); break;
10038         case RMS$_PRV:
10039           set_errno(EACCES); break;
10040         default:
10041           set_errno(EVMSERR);
10042       }
10043       return 0;
10044     }
10045     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10046     if (preserve_dates & 2) {
10047       /* sys$close() will process xabrdt, not xabdat */
10048       xabrdt = cc$rms_xabrdt;
10049 #ifndef __GNUC__
10050       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10051 #else
10052       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10053        * is unsigned long[2], while DECC & VAXC use a struct */
10054       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10055 #endif
10056       fab_out.fab$l_xab = (void *) &xabrdt;
10057     }
10058
10059     rab_in = cc$rms_rab;
10060     rab_in.rab$l_fab = &fab_in;
10061     rab_in.rab$l_rop = RAB$M_BIO;
10062     rab_in.rab$l_ubf = ubf;
10063     rab_in.rab$w_usz = sizeof ubf;
10064     if (!((sts = sys$connect(&rab_in)) & 1)) {
10065       sys$close(&fab_in); sys$close(&fab_out);
10066       set_errno(EVMSERR); set_vaxc_errno(sts);
10067       return 0;
10068     }
10069
10070     rab_out = cc$rms_rab;
10071     rab_out.rab$l_fab = &fab_out;
10072     rab_out.rab$l_rbf = ubf;
10073     if (!((sts = sys$connect(&rab_out)) & 1)) {
10074       sys$close(&fab_in); sys$close(&fab_out);
10075       set_errno(EVMSERR); set_vaxc_errno(sts);
10076       return 0;
10077     }
10078
10079     while ((sts = sys$read(&rab_in))) {  /* always true  */
10080       if (sts == RMS$_EOF) break;
10081       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10082       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10083         sys$close(&fab_in); sys$close(&fab_out);
10084         set_errno(EVMSERR); set_vaxc_errno(sts);
10085         return 0;
10086       }
10087     }
10088
10089     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10090     sys$close(&fab_in);  sys$close(&fab_out);
10091     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10092     if (!(sts & 1)) {
10093       set_errno(EVMSERR); set_vaxc_errno(sts);
10094       return 0;
10095     }
10096
10097     return 1;
10098
10099 }  /* end of rmscopy() */
10100 #else
10101 /* ODS-5 support version */
10102 int
10103 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10104 {
10105     char *vmsin, * vmsout, *esa, *esa_out,
10106          *rsa, *ubf;
10107     unsigned long int i, sts, sts2;
10108     struct FAB fab_in, fab_out;
10109     struct RAB rab_in, rab_out;
10110     struct NAML nam;
10111     struct NAML nam_out;
10112     struct XABDAT xabdat;
10113     struct XABFHC xabfhc;
10114     struct XABRDT xabrdt;
10115     struct XABSUM xabsum;
10116
10117     Newx(vmsin, VMS_MAXRSS, char);
10118     Newx(vmsout, VMS_MAXRSS, char);
10119     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10120         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10121       Safefree(vmsin);
10122       Safefree(vmsout);
10123       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10124       return 0;
10125     }
10126
10127     Newx(esa, VMS_MAXRSS, char);
10128     nam = cc$rms_naml;
10129     fab_in = cc$rms_fab;
10130     fab_in.fab$l_fna = (char *) -1;
10131     fab_in.fab$b_fns = 0;
10132     nam.naml$l_long_filename = vmsin;
10133     nam.naml$l_long_filename_size = strlen(vmsin);
10134     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10135     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10136     fab_in.fab$l_fop = FAB$M_SQO;
10137     fab_in.fab$l_naml =  &nam;
10138     fab_in.fab$l_xab = (void *) &xabdat;
10139
10140     Newx(rsa, VMS_MAXRSS, char);
10141     nam.naml$l_rsa = NULL;
10142     nam.naml$b_rss = 0;
10143     nam.naml$l_long_result = rsa;
10144     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10145     nam.naml$l_esa = NULL;
10146     nam.naml$b_ess = 0;
10147     nam.naml$l_long_expand = esa;
10148     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10149     nam.naml$b_esl = nam.naml$b_rsl = 0;
10150     nam.naml$l_long_expand_size = 0;
10151     nam.naml$l_long_result_size = 0;
10152 #ifdef NAM$M_NO_SHORT_UPCASE
10153     if (decc_efs_case_preserve)
10154         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10155 #endif
10156
10157     xabdat = cc$rms_xabdat;        /* To get creation date */
10158     xabdat.xab$l_nxt = (void *) &xabfhc;
10159
10160     xabfhc = cc$rms_xabfhc;        /* To get record length */
10161     xabfhc.xab$l_nxt = (void *) &xabsum;
10162
10163     xabsum = cc$rms_xabsum;        /* To get key and area information */
10164
10165     if (!((sts = sys$open(&fab_in)) & 1)) {
10166       Safefree(vmsin);
10167       Safefree(vmsout);
10168       Safefree(esa);
10169       Safefree(rsa);
10170       set_vaxc_errno(sts);
10171       switch (sts) {
10172         case RMS$_FNF: case RMS$_DNF:
10173           set_errno(ENOENT); break;
10174         case RMS$_DIR:
10175           set_errno(ENOTDIR); break;
10176         case RMS$_DEV:
10177           set_errno(ENODEV); break;
10178         case RMS$_SYN:
10179           set_errno(EINVAL); break;
10180         case RMS$_PRV:
10181           set_errno(EACCES); break;
10182         default:
10183           set_errno(EVMSERR);
10184       }
10185       return 0;
10186     }
10187
10188     nam_out = nam;
10189     fab_out = fab_in;
10190     fab_out.fab$w_ifi = 0;
10191     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10192     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10193     fab_out.fab$l_fop = FAB$M_SQO;
10194     fab_out.fab$l_naml = &nam_out;
10195     fab_out.fab$l_fna = (char *) -1;
10196     fab_out.fab$b_fns = 0;
10197     nam_out.naml$l_long_filename = vmsout;
10198     nam_out.naml$l_long_filename_size = strlen(vmsout);
10199     fab_out.fab$l_dna = (char *) -1;
10200     fab_out.fab$b_dns = 0;
10201     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10202     nam_out.naml$l_long_defname_size =
10203         nam.naml$l_long_name ?
10204            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10205
10206     Newx(esa_out, VMS_MAXRSS, char);
10207     nam_out.naml$l_rsa = NULL;
10208     nam_out.naml$b_rss = 0;
10209     nam_out.naml$l_long_result = NULL;
10210     nam_out.naml$l_long_result_alloc = 0;
10211     nam_out.naml$l_esa = NULL;
10212     nam_out.naml$b_ess = 0;
10213     nam_out.naml$l_long_expand = esa_out;
10214     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10215
10216     if (preserve_dates == 0) {  /* Act like DCL COPY */
10217       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10218       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10219       if (!((sts = sys$parse(&fab_out)) & 1)) {
10220         Safefree(vmsin);
10221         Safefree(vmsout);
10222         Safefree(esa);
10223         Safefree(rsa);
10224         Safefree(esa_out);
10225         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10226         set_vaxc_errno(sts);
10227         return 0;
10228       }
10229       fab_out.fab$l_xab = (void *) &xabdat;
10230       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10231     }
10232     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10233       preserve_dates =0;      /* bitmask from this point forward   */
10234
10235     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10236     if (!((sts = sys$create(&fab_out)) & 1)) {
10237       Safefree(vmsin);
10238       Safefree(vmsout);
10239       Safefree(esa);
10240       Safefree(rsa);
10241       Safefree(esa_out);
10242       set_vaxc_errno(sts);
10243       switch (sts) {
10244         case RMS$_DNF:
10245           set_errno(ENOENT); break;
10246         case RMS$_DIR:
10247           set_errno(ENOTDIR); break;
10248         case RMS$_DEV:
10249           set_errno(ENODEV); break;
10250         case RMS$_SYN:
10251           set_errno(EINVAL); break;
10252         case RMS$_PRV:
10253           set_errno(EACCES); break;
10254         default:
10255           set_errno(EVMSERR);
10256       }
10257       return 0;
10258     }
10259     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10260     if (preserve_dates & 2) {
10261       /* sys$close() will process xabrdt, not xabdat */
10262       xabrdt = cc$rms_xabrdt;
10263 #ifndef __GNUC__
10264       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10265 #else
10266       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10267        * is unsigned long[2], while DECC & VAXC use a struct */
10268       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10269 #endif
10270       fab_out.fab$l_xab = (void *) &xabrdt;
10271     }
10272
10273     Newx(ubf, 32256, char);
10274     rab_in = cc$rms_rab;
10275     rab_in.rab$l_fab = &fab_in;
10276     rab_in.rab$l_rop = RAB$M_BIO;
10277     rab_in.rab$l_ubf = ubf;
10278     rab_in.rab$w_usz = 32256;
10279     if (!((sts = sys$connect(&rab_in)) & 1)) {
10280       sys$close(&fab_in); sys$close(&fab_out);
10281       Safefree(vmsin);
10282       Safefree(vmsout);
10283       Safefree(esa);
10284       Safefree(ubf);
10285       Safefree(rsa);
10286       Safefree(esa_out);
10287       set_errno(EVMSERR); set_vaxc_errno(sts);
10288       return 0;
10289     }
10290
10291     rab_out = cc$rms_rab;
10292     rab_out.rab$l_fab = &fab_out;
10293     rab_out.rab$l_rbf = ubf;
10294     if (!((sts = sys$connect(&rab_out)) & 1)) {
10295       sys$close(&fab_in); sys$close(&fab_out);
10296       Safefree(vmsin);
10297       Safefree(vmsout);
10298       Safefree(esa);
10299       Safefree(ubf);
10300       Safefree(rsa);
10301       Safefree(esa_out);
10302       set_errno(EVMSERR); set_vaxc_errno(sts);
10303       return 0;
10304     }
10305
10306     while ((sts = sys$read(&rab_in))) {  /* always true  */
10307       if (sts == RMS$_EOF) break;
10308       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10309       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10310         sys$close(&fab_in); sys$close(&fab_out);
10311         Safefree(vmsin);
10312         Safefree(vmsout);
10313         Safefree(esa);
10314         Safefree(ubf);
10315         Safefree(rsa);
10316         Safefree(esa_out);
10317         set_errno(EVMSERR); set_vaxc_errno(sts);
10318         return 0;
10319       }
10320     }
10321
10322
10323     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10324     sys$close(&fab_in);  sys$close(&fab_out);
10325     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10326     if (!(sts & 1)) {
10327       Safefree(vmsin);
10328       Safefree(vmsout);
10329       Safefree(esa);
10330       Safefree(ubf);
10331       Safefree(rsa);
10332       Safefree(esa_out);
10333       set_errno(EVMSERR); set_vaxc_errno(sts);
10334       return 0;
10335     }
10336
10337     Safefree(vmsin);
10338     Safefree(vmsout);
10339     Safefree(esa);
10340     Safefree(ubf);
10341     Safefree(rsa);
10342     Safefree(esa_out);
10343     return 1;
10344
10345 }  /* end of rmscopy() */
10346 #endif
10347 /*}}}*/
10348
10349
10350 /***  The following glue provides 'hooks' to make some of the routines
10351  * from this file available from Perl.  These routines are sufficiently
10352  * basic, and are required sufficiently early in the build process,
10353  * that's it's nice to have them available to miniperl as well as the
10354  * full Perl, so they're set up here instead of in an extension.  The
10355  * Perl code which handles importation of these names into a given
10356  * package lives in [.VMS]Filespec.pm in @INC.
10357  */
10358
10359 void
10360 rmsexpand_fromperl(pTHX_ CV *cv)
10361 {
10362   dXSARGS;
10363   char *fspec, *defspec = NULL, *rslt;
10364   STRLEN n_a;
10365
10366   if (!items || items > 2)
10367     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10368   fspec = SvPV(ST(0),n_a);
10369   if (!fspec || !*fspec) XSRETURN_UNDEF;
10370   if (items == 2) defspec = SvPV(ST(1),n_a);
10371
10372   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10373   ST(0) = sv_newmortal();
10374   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10375   XSRETURN(1);
10376 }
10377
10378 void
10379 vmsify_fromperl(pTHX_ CV *cv)
10380 {
10381   dXSARGS;
10382   char *vmsified;
10383   STRLEN n_a;
10384
10385   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10386   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10387   ST(0) = sv_newmortal();
10388   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10389   XSRETURN(1);
10390 }
10391
10392 void
10393 unixify_fromperl(pTHX_ CV *cv)
10394 {
10395   dXSARGS;
10396   char *unixified;
10397   STRLEN n_a;
10398
10399   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10400   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10401   ST(0) = sv_newmortal();
10402   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10403   XSRETURN(1);
10404 }
10405
10406 void
10407 fileify_fromperl(pTHX_ CV *cv)
10408 {
10409   dXSARGS;
10410   char *fileified;
10411   STRLEN n_a;
10412
10413   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10414   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10415   ST(0) = sv_newmortal();
10416   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10417   XSRETURN(1);
10418 }
10419
10420 void
10421 pathify_fromperl(pTHX_ CV *cv)
10422 {
10423   dXSARGS;
10424   char *pathified;
10425   STRLEN n_a;
10426
10427   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10428   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10429   ST(0) = sv_newmortal();
10430   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10431   XSRETURN(1);
10432 }
10433
10434 void
10435 vmspath_fromperl(pTHX_ CV *cv)
10436 {
10437   dXSARGS;
10438   char *vmspath;
10439   STRLEN n_a;
10440
10441   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10442   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10443   ST(0) = sv_newmortal();
10444   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10445   XSRETURN(1);
10446 }
10447
10448 void
10449 unixpath_fromperl(pTHX_ CV *cv)
10450 {
10451   dXSARGS;
10452   char *unixpath;
10453   STRLEN n_a;
10454
10455   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10456   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10457   ST(0) = sv_newmortal();
10458   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10459   XSRETURN(1);
10460 }
10461
10462 void
10463 candelete_fromperl(pTHX_ CV *cv)
10464 {
10465   dXSARGS;
10466   char fspec[NAM$C_MAXRSS+1], *fsp;
10467   SV *mysv;
10468   IO *io;
10469   STRLEN n_a;
10470
10471   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10472
10473   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10474   if (SvTYPE(mysv) == SVt_PVGV) {
10475     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10476       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10477       ST(0) = &PL_sv_no;
10478       XSRETURN(1);
10479     }
10480     fsp = fspec;
10481   }
10482   else {
10483     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10484       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10485       ST(0) = &PL_sv_no;
10486       XSRETURN(1);
10487     }
10488   }
10489
10490   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10491   XSRETURN(1);
10492 }
10493
10494 void
10495 rmscopy_fromperl(pTHX_ CV *cv)
10496 {
10497   dXSARGS;
10498   char *inspec, *outspec, *inp, *outp;
10499   int date_flag;
10500   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10501                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10502   unsigned long int sts;
10503   SV *mysv;
10504   IO *io;
10505   STRLEN n_a;
10506
10507   if (items < 2 || items > 3)
10508     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10509
10510   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10511   Newx(inspec, VMS_MAXRSS, char);
10512   if (SvTYPE(mysv) == SVt_PVGV) {
10513     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10514       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10515       ST(0) = &PL_sv_no;
10516       Safefree(inspec);
10517       XSRETURN(1);
10518     }
10519     inp = inspec;
10520   }
10521   else {
10522     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10523       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10524       ST(0) = &PL_sv_no;
10525       Safefree(inspec);
10526       XSRETURN(1);
10527     }
10528   }
10529   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10530   Newx(outspec, VMS_MAXRSS, char);
10531   if (SvTYPE(mysv) == SVt_PVGV) {
10532     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10533       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10534       ST(0) = &PL_sv_no;
10535       Safefree(inspec);
10536       Safefree(outspec);
10537       XSRETURN(1);
10538     }
10539     outp = outspec;
10540   }
10541   else {
10542     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10543       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10544       ST(0) = &PL_sv_no;
10545       Safefree(inspec);
10546       Safefree(outspec);
10547       XSRETURN(1);
10548     }
10549   }
10550   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10551
10552   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10553   Safefree(inspec);
10554   Safefree(outspec);
10555   XSRETURN(1);
10556 }
10557
10558 /* The mod2fname is limited to shorter filenames by design, so it should
10559  * not be modified to support longer EFS pathnames
10560  */
10561 void
10562 mod2fname(pTHX_ CV *cv)
10563 {
10564   dXSARGS;
10565   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10566        workbuff[NAM$C_MAXRSS*1 + 1];
10567   int total_namelen = 3, counter, num_entries;
10568   /* ODS-5 ups this, but we want to be consistent, so... */
10569   int max_name_len = 39;
10570   AV *in_array = (AV *)SvRV(ST(0));
10571
10572   num_entries = av_len(in_array);
10573
10574   /* All the names start with PL_. */
10575   strcpy(ultimate_name, "PL_");
10576
10577   /* Clean up our working buffer */
10578   Zero(work_name, sizeof(work_name), char);
10579
10580   /* Run through the entries and build up a working name */
10581   for(counter = 0; counter <= num_entries; counter++) {
10582     /* If it's not the first name then tack on a __ */
10583     if (counter) {
10584       strcat(work_name, "__");
10585     }
10586     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10587                            PL_na));
10588   }
10589
10590   /* Check to see if we actually have to bother...*/
10591   if (strlen(work_name) + 3 <= max_name_len) {
10592     strcat(ultimate_name, work_name);
10593   } else {
10594     /* It's too darned big, so we need to go strip. We use the same */
10595     /* algorithm as xsubpp does. First, strip out doubled __ */
10596     char *source, *dest, last;
10597     dest = workbuff;
10598     last = 0;
10599     for (source = work_name; *source; source++) {
10600       if (last == *source && last == '_') {
10601         continue;
10602       }
10603       *dest++ = *source;
10604       last = *source;
10605     }
10606     /* Go put it back */
10607     strcpy(work_name, workbuff);
10608     /* Is it still too big? */
10609     if (strlen(work_name) + 3 > max_name_len) {
10610       /* Strip duplicate letters */
10611       last = 0;
10612       dest = workbuff;
10613       for (source = work_name; *source; source++) {
10614         if (last == toupper(*source)) {
10615         continue;
10616         }
10617         *dest++ = *source;
10618         last = toupper(*source);
10619       }
10620       strcpy(work_name, workbuff);
10621     }
10622
10623     /* Is it *still* too big? */
10624     if (strlen(work_name) + 3 > max_name_len) {
10625       /* Too bad, we truncate */
10626       work_name[max_name_len - 2] = 0;
10627     }
10628     strcat(ultimate_name, work_name);
10629   }
10630
10631   /* Okay, return it */
10632   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10633   XSRETURN(1);
10634 }
10635
10636 void
10637 hushexit_fromperl(pTHX_ CV *cv)
10638 {
10639     dXSARGS;
10640
10641     if (items > 0) {
10642         VMSISH_HUSHED = SvTRUE(ST(0));
10643     }
10644     ST(0) = boolSV(VMSISH_HUSHED);
10645     XSRETURN(1);
10646 }
10647
10648 #ifdef HAS_SYMLINK
10649 static char *
10650 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10651
10652 void
10653 vms_realpath_fromperl(pTHX_ CV *cv)
10654 {
10655   dXSARGS;
10656   char *fspec, *rslt_spec, *rslt;
10657   STRLEN n_a;
10658
10659   if (!items || items != 1)
10660     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10661
10662   fspec = SvPV(ST(0),n_a);
10663   if (!fspec || !*fspec) XSRETURN_UNDEF;
10664
10665   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10666   rslt = do_vms_realpath(fspec, rslt_spec);
10667   ST(0) = sv_newmortal();
10668   if (rslt != NULL)
10669     sv_usepvn(ST(0),rslt,strlen(rslt));
10670   else
10671     Safefree(rslt_spec);
10672   XSRETURN(1);
10673 }
10674 #endif
10675
10676 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10677 int do_vms_case_tolerant(void);
10678
10679 void
10680 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10681 {
10682   dXSARGS;
10683   ST(0) = boolSV(do_vms_case_tolerant());
10684   XSRETURN(1);
10685 }
10686 #endif
10687
10688 void
10689 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10690                           struct interp_intern *dst)
10691 {
10692     memcpy(dst,src,sizeof(struct interp_intern));
10693 }
10694
10695 void
10696 Perl_sys_intern_clear(pTHX)
10697 {
10698 }
10699
10700 void
10701 Perl_sys_intern_init(pTHX)
10702 {
10703     unsigned int ix = RAND_MAX;
10704     double x;
10705
10706     VMSISH_HUSHED = 0;
10707
10708     /* fix me later to track running under GNV */
10709     /* this allows some limited testing */
10710     MY_POSIX_EXIT = decc_filename_unix_report;
10711
10712     x = (float)ix;
10713     MY_INV_RAND_MAX = 1./x;
10714 }
10715
10716 void
10717 init_os_extras(void)
10718 {
10719   dTHX;
10720   char* file = __FILE__;
10721   char temp_buff[512];
10722   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10723     no_translate_barewords = TRUE;
10724   } else {
10725     no_translate_barewords = FALSE;
10726   }
10727
10728   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10729   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10730   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10731   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10732   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10733   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10734   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10735   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10736   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10737   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10738   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10739 #ifdef HAS_SYMLINK
10740   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10741 #endif
10742 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10743   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10744 #endif
10745
10746   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10747
10748   return;
10749 }
10750
10751 #ifdef HAS_SYMLINK
10752
10753 #if __CRTL_VER == 80200000
10754 /* This missed getting in to the DECC SDK for 8.2 */
10755 char *realpath(const char *file_name, char * resolved_name, ...);
10756 #endif
10757
10758 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10759 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10760  * The perl fallback routine to provide realpath() is not as efficient
10761  * on OpenVMS.
10762  */
10763 static char *
10764 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10765 {
10766     return realpath(filespec, outbuf);
10767 }
10768
10769 /*}}}*/
10770 /* External entry points */
10771 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10772 { return do_vms_realpath(filespec, outbuf); }
10773 #else
10774 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10775 { return NULL; }
10776 #endif
10777
10778
10779 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10780 /* case_tolerant */
10781
10782 /*{{{int do_vms_case_tolerant(void)*/
10783 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10784  * controlled by a process setting.
10785  */
10786 int do_vms_case_tolerant(void)
10787 {
10788     return vms_process_case_tolerant;
10789 }
10790 /*}}}*/
10791 /* External entry points */
10792 int Perl_vms_case_tolerant(void)
10793 { return do_vms_case_tolerant(); }
10794 #else
10795 int Perl_vms_case_tolerant(void)
10796 { return vms_process_case_tolerant; }
10797 #endif
10798
10799
10800  /* Start of DECC RTL Feature handling */
10801
10802 static int sys_trnlnm
10803    (const char * logname,
10804     char * value,
10805     int value_len)
10806 {
10807     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10808     const unsigned long attr = LNM$M_CASE_BLIND;
10809     struct dsc$descriptor_s name_dsc;
10810     int status;
10811     unsigned short result;
10812     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10813                                 {0, 0, 0, 0}};
10814
10815     name_dsc.dsc$w_length = strlen(logname);
10816     name_dsc.dsc$a_pointer = (char *)logname;
10817     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10818     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10819
10820     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10821
10822     if ($VMS_STATUS_SUCCESS(status)) {
10823
10824          /* Null terminate and return the string */
10825         /*--------------------------------------*/
10826         value[result] = 0;
10827     }
10828
10829     return status;
10830 }
10831
10832 static int sys_crelnm
10833    (const char * logname,
10834     const char * value)
10835 {
10836     int ret_val;
10837     const char * proc_table = "LNM$PROCESS_TABLE";
10838     struct dsc$descriptor_s proc_table_dsc;
10839     struct dsc$descriptor_s logname_dsc;
10840     struct itmlst_3 item_list[2];
10841
10842     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10843     proc_table_dsc.dsc$w_length = strlen(proc_table);
10844     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10845     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10846
10847     logname_dsc.dsc$a_pointer = (char *) logname;
10848     logname_dsc.dsc$w_length = strlen(logname);
10849     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10850     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10851
10852     item_list[0].buflen = strlen(value);
10853     item_list[0].itmcode = LNM$_STRING;
10854     item_list[0].bufadr = (char *)value;
10855     item_list[0].retlen = NULL;
10856
10857     item_list[1].buflen = 0;
10858     item_list[1].itmcode = 0;
10859
10860     ret_val = sys$crelnm
10861                        (NULL,
10862                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10863                         (const struct dsc$descriptor_s *)&logname_dsc,
10864                         NULL,
10865                         (const struct item_list_3 *) item_list);
10866
10867     return ret_val;
10868 }
10869
10870
10871 /* C RTL Feature settings */
10872
10873 static int set_features
10874    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10875     int (* cli_routine)(void),  /* Not documented */
10876     void *image_info)           /* Not documented */
10877 {
10878     int status;
10879     int s;
10880     int dflt;
10881     char* str;
10882     char val_str[10];
10883     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10884     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10885     unsigned long case_perm;
10886     unsigned long case_image;
10887
10888     /* hacks to see if known bugs are still present for testing */
10889
10890     /* Readdir is returning filenames in VMS syntax always */
10891     decc_bug_readdir_efs1 = 1;
10892     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10893     if ($VMS_STATUS_SUCCESS(status)) {
10894        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10895          decc_bug_readdir_efs1 = 1;
10896        else
10897          decc_bug_readdir_efs1 = 0;
10898     }
10899
10900     /* PCP mode requires creating /dev/null special device file */
10901     decc_bug_devnull = 0;
10902     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10903     if ($VMS_STATUS_SUCCESS(status)) {
10904        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10905           decc_bug_devnull = 1;
10906     }
10907
10908     /* fgetname returning a VMS name in UNIX mode */
10909     decc_bug_fgetname = 1;
10910     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10911     if ($VMS_STATUS_SUCCESS(status)) {
10912       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10913         decc_bug_fgetname = 1;
10914       else
10915         decc_bug_fgetname = 0;
10916     }
10917
10918     /* UNIX directory names with no paths are broken in a lot of places */
10919     decc_dir_barename = 1;
10920     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10921     if ($VMS_STATUS_SUCCESS(status)) {
10922       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10923         decc_dir_barename = 1;
10924       else
10925         decc_dir_barename = 0;
10926     }
10927
10928 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10929     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10930     if (s >= 0) {
10931         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10932         if (decc_disable_to_vms_logname_translation < 0)
10933             decc_disable_to_vms_logname_translation = 0;
10934     }
10935
10936     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10937     if (s >= 0) {
10938         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10939         if (decc_efs_case_preserve < 0)
10940             decc_efs_case_preserve = 0;
10941     }
10942
10943     s = decc$feature_get_index("DECC$EFS_CHARSET");
10944     if (s >= 0) {
10945         decc_efs_charset = decc$feature_get_value(s, 1);
10946         if (decc_efs_charset < 0)
10947             decc_efs_charset = 0;
10948     }
10949
10950     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10951     if (s >= 0) {
10952         decc_filename_unix_report = decc$feature_get_value(s, 1);
10953         if (decc_filename_unix_report > 0)
10954             decc_filename_unix_report = 1;
10955         else
10956             decc_filename_unix_report = 0;
10957     }
10958
10959     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10960     if (s >= 0) {
10961         decc_filename_unix_only = decc$feature_get_value(s, 1);
10962         if (decc_filename_unix_only > 0) {
10963             decc_filename_unix_only = 1;
10964         }
10965         else {
10966             decc_filename_unix_only = 0;
10967         }
10968     }
10969
10970     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10971     if (s >= 0) {
10972         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10973         if (decc_filename_unix_no_version < 0)
10974             decc_filename_unix_no_version = 0;
10975     }
10976
10977     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10978     if (s >= 0) {
10979         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10980         if (decc_readdir_dropdotnotype < 0)
10981             decc_readdir_dropdotnotype = 0;
10982     }
10983
10984     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10985     if ($VMS_STATUS_SUCCESS(status)) {
10986         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10987         if (s >= 0) {
10988             dflt = decc$feature_get_value(s, 4);
10989             if (dflt > 0) {
10990                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10991                 if (decc_disable_posix_root <= 0) {
10992                     decc$feature_set_value(s, 1, 1);
10993                     decc_disable_posix_root = 1;
10994                 }
10995             }
10996             else {
10997                 /* Traditionally Perl assumes this is off */
10998                 decc_disable_posix_root = 1;
10999                 decc$feature_set_value(s, 1, 1);
11000             }
11001         }
11002     }
11003
11004 #if __CRTL_VER >= 80200000
11005     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11006     if (s >= 0) {
11007         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11008         if (decc_posix_compliant_pathnames < 0)
11009             decc_posix_compliant_pathnames = 0;
11010         if (decc_posix_compliant_pathnames > 4)
11011             decc_posix_compliant_pathnames = 0;
11012     }
11013
11014 #endif
11015 #else
11016     status = sys_trnlnm
11017         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11018     if ($VMS_STATUS_SUCCESS(status)) {
11019         val_str[0] = _toupper(val_str[0]);
11020         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11021            decc_disable_to_vms_logname_translation = 1;
11022         }
11023     }
11024
11025 #ifndef __VAX
11026     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11027     if ($VMS_STATUS_SUCCESS(status)) {
11028         val_str[0] = _toupper(val_str[0]);
11029         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11030            decc_efs_case_preserve = 1;
11031         }
11032     }
11033 #endif
11034
11035     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11036     if ($VMS_STATUS_SUCCESS(status)) {
11037         val_str[0] = _toupper(val_str[0]);
11038         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11039            decc_filename_unix_report = 1;
11040         }
11041     }
11042     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11043     if ($VMS_STATUS_SUCCESS(status)) {
11044         val_str[0] = _toupper(val_str[0]);
11045         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11046            decc_filename_unix_only = 1;
11047            decc_filename_unix_report = 1;
11048         }
11049     }
11050     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11051     if ($VMS_STATUS_SUCCESS(status)) {
11052         val_str[0] = _toupper(val_str[0]);
11053         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11054            decc_filename_unix_no_version = 1;
11055         }
11056     }
11057     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11058     if ($VMS_STATUS_SUCCESS(status)) {
11059         val_str[0] = _toupper(val_str[0]);
11060         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11061            decc_readdir_dropdotnotype = 1;
11062         }
11063     }
11064 #endif
11065
11066 #ifndef __VAX
11067
11068      /* Report true case tolerance */
11069     /*----------------------------*/
11070     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11071     if (!$VMS_STATUS_SUCCESS(status))
11072         case_perm = PPROP$K_CASE_BLIND;
11073     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11074     if (!$VMS_STATUS_SUCCESS(status))
11075         case_image = PPROP$K_CASE_BLIND;
11076     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11077         (case_image == PPROP$K_CASE_SENSITIVE))
11078         vms_process_case_tolerant = 0;
11079
11080 #endif
11081
11082
11083     /* CRTL can be initialized past this point, but not before. */
11084 /*    DECC$CRTL_INIT(); */
11085
11086     return SS$_NORMAL;
11087 }
11088
11089 #ifdef __DECC
11090 /* DECC dependent attributes */
11091 #if __DECC_VER < 60560002
11092 #define relative
11093 #define not_executable
11094 #else
11095 #define relative ,rel
11096 #define not_executable ,noexe
11097 #endif
11098 #pragma nostandard
11099 #pragma extern_model save
11100 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11101 #endif
11102         const __align (LONGWORD) int spare[8] = {0};
11103 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11104 /*                        NOWRT, LONG */
11105 #ifdef __DECC
11106 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11107         nowrt,noshr relative not_executable
11108 #endif
11109 const long vms_cc_features = (const long)set_features;
11110
11111 /*
11112 ** Force a reference to LIB$INITIALIZE to ensure it
11113 ** exists in the image.
11114 */
11115 int lib$initialize(void);
11116 #ifdef __DECC
11117 #pragma extern_model strict_refdef
11118 #endif
11119     int lib_init_ref = (int) lib$initialize;
11120
11121 #ifdef __DECC
11122 #pragma extern_model restore
11123 #pragma standard
11124 #endif
11125
11126 /*  End of vms.c */