vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #define VMS_MAXRSS NAM$C_MAXRSS
  61 #ifndef __VAX
  62 #if 0
  63 #ifdef NAML$C_MAXRSS
  64 #undef VMS_MAXRSS
  65 #define VMS_MAXRSS NAML$C_MAXRSS
  66 #endif
  67 #endif
  68 #endif
  69
  70 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  71 int   decc$feature_get_index(const char *name);
  72 char* decc$feature_get_name(int index);
  73 int   decc$feature_get_value(int index, int mode);
  74 int   decc$feature_set_value(int index, int mode, int value);
  75 #else
  76 #include <unixlib.h>
  77 #endif
  78
  79 #ifndef __VAX
  80 #if __CRTL_VER >= 70300000
  81
  82 static int set_feature_default(const char *name, int value)
  83 {
  84     int status;
  85     int index;
  86
  87     index = decc$feature_get_index(name);
  88
  89     status = decc$feature_set_value(index, 1, value);
  90     if (index == -1 || (status == -1)) {
  91       return -1;
  92     }
  93
  94     status = decc$feature_get_value(index, 1);
  95     if (status != value) {
  96       return -1;
  97     }
  98
  99 return 0;
 100 }
 101 #endif
 102 #endif
 103
 104 /* Older versions of ssdef.h don't have these */
 105 #ifndef SS$_INVFILFOROP
 106 #  define SS$_INVFILFOROP 3930
 107 #endif
 108 #ifndef SS$_NOSUCHOBJECT
 109 #  define SS$_NOSUCHOBJECT 2696
 110 #endif
 111
 112 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 113 #define PERLIO_NOT_STDIO 0
 114
 115 /* Don't replace system definitions of vfork, getenv, and stat,
 116  * code below needs to get to the underlying CRTL routines. */
 117 #define DONT_MASK_RTL_CALLS
 118 #include "EXTERN.h"
 119 #include "perl.h"
 120 #include "XSUB.h"
 121 /* Anticipating future expansion in lexical warnings . . . */
 122 #ifndef WARN_INTERNAL
 123 #  define WARN_INTERNAL WARN_MISC
 124 #endif
 125
 126 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 127 #  define RTL_USES_UTC 1
 128 #endif
 129
 130
 131 /* gcc's header files don't #define direct access macros
 132  * corresponding to VAXC's variant structs */
 133 #ifdef __GNUC__
 134 #  define uic$v_format uic$r_uic_form.uic$v_format
 135 #  define uic$v_group uic$r_uic_form.uic$v_group
 136 #  define uic$v_member uic$r_uic_form.uic$v_member
 137 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 138 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 139 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 140 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 141 #endif
 142
 143 #if defined(NEED_AN_H_ERRNO)
 144 dEXT int h_errno;
 145 #endif
 146
 147 #ifdef __DECC
 148 #pragma message disable pragma
 149 #pragma member_alignment save
 150 #pragma nomember_alignment longword
 151 #pragma message save
 152 #pragma message disable misalgndmem
 153 #endif
 154 struct itmlst_3 {
 155   unsigned short int buflen;
 156   unsigned short int itmcode;
 157   void *bufadr;
 158   unsigned short int *retlen;
 159 };
 160 #ifdef __DECC
 161 #pragma message restore
 162 #pragma member_alignment restore
 163 #endif
 164
 165 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 166 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 167 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 168 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 169 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 170 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 171 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 172 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 173 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 174 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 175 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 176
 177 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 178 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 179 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 180 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 181
 182 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 183 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 184
 185 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 186  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 187  * the Perl facility.
 188  */
 189 #define PERL_LNM_MAX_ITER 10
 190
 191 #define MAX_DCL_SYMBOL              255     /* well, what *we* can set, at least*/
 192 #define MAX_DCL_LINE_LENGTH        (4*MAX_DCL_SYMBOL-4)
 193
 194 static char *__mystrtolower(char *str)
 195 {
 196   if (str) for (; *str; ++str) *str= tolower(*str);
 197   return str;
 198 }
 199
 200 static struct dsc$descriptor_s fildevdsc =
 201   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 202 static struct dsc$descriptor_s crtlenvdsc =
 203   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 204 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 205 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 206 static struct dsc$descriptor_s **env_tables = defenv;
 207 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 208
 209 /* True if we shouldn't treat barewords as logicals during directory */
 210 /* munching */
 211 static int no_translate_barewords;
 212
 213 #ifndef RTL_USES_UTC
 214 static int tz_updated = 1;
 215 #endif
 216
 217 /* DECC Features that may need to affect how Perl interprets
 218  * displays filename information
 219  */
 220 static int decc_disable_to_vms_logname_translation = 1;
 221 static int decc_disable_posix_root = 1;
 222 int decc_efs_case_preserve = 0;
 223 static int decc_efs_charset = 0;
 224 static int decc_filename_unix_no_version = 0;
 225 static int decc_filename_unix_only = 0;
 226 int decc_filename_unix_report = 0;
 227 int decc_posix_compliant_pathnames = 0;
 228 int decc_readdir_dropdotnotype = 0;
 229 static int vms_process_case_tolerant = 1;
 230
 231 /* Is this a UNIX file specification?
 232  *   No longer a simple check with EFS file specs
 233  *   For now, not a full check, but need to
 234  *   handle POSIX ^UP^ specifications
 235  *   Fixing to handle ^/ cases would require
 236  *   changes to many other conversion routines.
 237  */
 238
 239 static is_unix_filespec(const char *path)
 240 {
 241 int ret_val;
 242 const char * pch1;
 243
 244     ret_val = 0;
 245     if (strncmp(path,"\"^UP^",5) != 0) {
 246         pch1 = strchr(path, '/');
 247         if (pch1 != NULL)
 248             ret_val = 1;
 249         else {
 250
 251             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 252             if (decc_filename_unix_report || decc_filename_unix_only) {
 253             if (strcmp(path,".") == 0)
 254                 ret_val = 1;
 255             }
 256         }
 257     }
 258     return ret_val;
 259 }
 260
 261
 262 /* my_maxidx
 263  * Routine to retrieve the maximum equivalence index for an input
 264  * logical name.  Some calls to this routine have no knowledge if
 265  * the variable is a logical or not.  So on error we return a max
 266  * index of zero.
 267  */
 268 /*{{{int my_maxidx(const char *lnm) */
 269 static int
 270 my_maxidx(const char *lnm)
 271 {
 272     int status;
 273     int midx;
 274     int attr = LNM$M_CASE_BLIND;
 275     struct dsc$descriptor lnmdsc;
 276     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 277                                 {0, 0, 0, 0}};
 278
 279     lnmdsc.dsc$w_length = strlen(lnm);
 280     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 281     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 282     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 283
 284     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 285     if ((status & 1) == 0)
 286        midx = 0;
 287
 288     return (midx);
 289 }
 290 /*}}}*/
 291
 292 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 293 int
 294 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 295   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 296 {
 297     const char *cp1;
 298     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 299     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 300     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 301     int midx;
 302     unsigned char acmode;
 303     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 304                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 305     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 306                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 307                                  {0, 0, 0, 0}};
 308     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 309 #if defined(PERL_IMPLICIT_CONTEXT)
 310     pTHX = NULL;
 311     if (PL_curinterp) {
 312       aTHX = PERL_GET_INTERP;
 313     } else {
 314       aTHX = NULL;
 315     }
 316 #endif
 317
 318     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 319       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 320     }
 321     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 322       *cp2 = _toupper(*cp1);
 323       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 324         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 325         return 0;
 326       }
 327     }
 328     lnmdsc.dsc$w_length = cp1 - lnm;
 329     lnmdsc.dsc$a_pointer = uplnm;
 330     uplnm[lnmdsc.dsc$w_length] = '\0';
 331     secure = flags & PERL__TRNENV_SECURE;
 332     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 333     if (!tabvec || !*tabvec) tabvec = env_tables;
 334
 335     for (curtab = 0; tabvec[curtab]; curtab++) {
 336       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 337         if (!ivenv && !secure) {
 338           char *eq, *end;
 339           int i;
 340           if (!environ) {
 341             ivenv = 1;
 342             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 343             continue;
 344           }
 345           retsts = SS$_NOLOGNAM;
 346           for (i = 0; environ[i]; i++) {
 347             if ((eq = strchr(environ[i],'=')) &&
 348                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 349                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 350               eq++;
 351               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 352               if (!eqvlen) continue;
 353               retsts = SS$_NORMAL;
 354               break;
 355             }
 356           }
 357           if (retsts != SS$_NOLOGNAM) break;
 358         }
 359       }
 360       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 361                !str$case_blind_compare(&tmpdsc,&clisym)) {
 362         if (!ivsym && !secure) {
 363           unsigned short int deflen = LNM$C_NAMLENGTH;
 364           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 365           /* dynamic dsc to accomodate possible long value */
 366           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 367           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 368           if (retsts & 1) {
 369             if (eqvlen > 1024) {
 370               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 371               eqvlen = 1024;
 372               /* Special hack--we might be called before the interpreter's */
 373               /* fully initialized, in which case either thr or PL_curcop */
 374               /* might be bogus. We have to check, since ckWARN needs them */
 375               /* both to be valid if running threaded */
 376                 if (ckWARN(WARN_MISC)) {
 377                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 378                 }
 379             }
 380             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 381           }
 382           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 383           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 384           if (retsts == LIB$_NOSUCHSYM) continue;
 385           break;
 386         }
 387       }
 388       else if (!ivlnm) {
 389         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 390           midx = my_maxidx(lnm);
 391           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 392             lnmlst[1].bufadr = cp2;
 393             eqvlen = 0;
 394             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 395             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 396             if (retsts == SS$_NOLOGNAM) break;
 397             /* PPFs have a prefix */
 398             if (
 399 #if INTSIZE == 4
 400                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 401 #endif
 402                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 403                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 404                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 405                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 406                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 407               memcpy(eqv,eqv+4,eqvlen-4);
 408               eqvlen -= 4;
 409             }
 410             cp2 += eqvlen;
 411             *cp2 = '\0';
 412           }
 413           if ((retsts == SS$_IVLOGNAM) ||
 414               (retsts == SS$_NOLOGNAM)) { continue; }
 415         }
 416         else {
 417           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 418           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 419           if (retsts == SS$_NOLOGNAM) continue;
 420           eqv[eqvlen] = '\0';
 421         }
 422         eqvlen = strlen(eqv);
 423         break;
 424       }
 425     }
 426     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 427     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 428              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 429              retsts == SS$_NOLOGNAM) {
 430       set_errno(EINVAL);  set_vaxc_errno(retsts);
 431     }
 432     else _ckvmssts(retsts);
 433     return 0;
 434 }  /* end of vmstrnenv */
 435 /*}}}*/
 436
 437 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 438 /* Define as a function so we can access statics. */
 439 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 440 {
 441   return vmstrnenv(lnm,eqv,idx,fildev,
 442 #ifdef SECURE_INTERNAL_GETENV
 443                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 444 #else
 445                    0
 446 #endif
 447                                                                               );
 448 }
 449 /*}}}*/
 450
 451 /* my_getenv
 452  * Note: Uses Perl temp to store result so char * can be returned to
 453  * caller; this pointer will be invalidated at next Perl statement
 454  * transition.
 455  * We define this as a function rather than a macro in terms of my_getenv_len()
 456  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 457  * allocate SVs).
 458  */
 459 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 460 char *
 461 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 462 {
 463     const char *cp1;
 464     static char *__my_getenv_eqv = NULL;
 465     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 466     unsigned long int idx = 0;
 467     int trnsuccess, success, secure, saverr, savvmserr;
 468     int midx, flags;
 469     SV *tmpsv;
 470
 471     midx = my_maxidx(lnm) + 1;
 472
 473     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 474       /* Set up a temporary buffer for the return value; Perl will
 475        * clean it up at the next statement transition */
 476       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 477       if (!tmpsv) return NULL;
 478       eqv = SvPVX(tmpsv);
 479     }
 480     else {
 481       /* Assume no interpreter ==> single thread */
 482       if (__my_getenv_eqv != NULL) {
 483         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 484       }
 485       else {
 486         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 487       }
 488       eqv = __my_getenv_eqv;
 489     }
 490
 491     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 492     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 493       getcwd(eqv,LNM$C_NAMLENGTH);
 494       return eqv;
 495     }
 496     else {
 497       /* Impose security constraints only if tainting */
 498       if (sys) {
 499         /* Impose security constraints only if tainting */
 500         secure = PL_curinterp ? PL_tainting : will_taint;
 501         saverr = errno;  savvmserr = vaxc$errno;
 502       }
 503       else {
 504         secure = 0;
 505       }
 506
 507       flags =
 508 #ifdef SECURE_INTERNAL_GETENV
 509               secure ? PERL__TRNENV_SECURE : 0
 510 #else
 511               0
 512 #endif
 513       ;
 514
 515       /* For the getenv interface we combine all the equivalence names
 516        * of a search list logical into one value to acquire a maximum
 517        * value length of 255*128 (assuming %ENV is using logicals).
 518        */
 519       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 520
 521       /* If the name contains a semicolon-delimited index, parse it
 522        * off and make sure we only retrieve the equivalence name for
 523        * that index.  */
 524       if ((cp2 = strchr(lnm,';')) != NULL) {
 525         strcpy(uplnm,lnm);
 526         uplnm[cp2-lnm] = '\0';
 527         idx = strtoul(cp2+1,NULL,0);
 528         lnm = uplnm;
 529         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 530       }
 531
 532       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 533
 534       /* Discard NOLOGNAM on internal calls since we're often looking
 535        * for an optional name, and this "error" often shows up as the
 536        * (bogus) exit status for a die() call later on.  */
 537       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 538       return success ? eqv : Nullch;
 539     }
 540
 541 }  /* end of my_getenv() */
 542 /*}}}*/
 543
 544
 545 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 546 char *
 547 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 548 {
 549     const char *cp1;
 550     char *buf, *cp2;
 551     unsigned long idx = 0;
 552     int midx, flags;
 553     static char *__my_getenv_len_eqv = NULL;
 554     int secure, saverr, savvmserr;
 555     SV *tmpsv;
 556
 557     midx = my_maxidx(lnm) + 1;
 558
 559     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 560       /* Set up a temporary buffer for the return value; Perl will
 561        * clean it up at the next statement transition */
 562       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 563       if (!tmpsv) return NULL;
 564       buf = SvPVX(tmpsv);
 565     }
 566     else {
 567       /* Assume no interpreter ==> single thread */
 568       if (__my_getenv_len_eqv != NULL) {
 569         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 570       }
 571       else {
 572         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 573       }
 574       buf = __my_getenv_len_eqv;
 575     }
 576
 577     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 578     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 579     char * zeros;
 580
 581       getcwd(buf,LNM$C_NAMLENGTH);
 582       *len = strlen(buf);
 583
 584       /* Get rid of "000000/ in rooted filespecs */
 585       if (*len > 7) {
 586       zeros = strstr(buf, "/000000/");
 587       if (zeros != NULL) {
 588         int mlen;
 589         mlen = *len - (zeros - buf) - 7;
 590         memmove(zeros, &zeros[7], mlen);
 591         *len = *len - 7;
 592         buf[*len] = '\0';
 593         }
 594       }
 595       return buf;
 596     }
 597     else {
 598       if (sys) {
 599         /* Impose security constraints only if tainting */
 600         secure = PL_curinterp ? PL_tainting : will_taint;
 601         saverr = errno;  savvmserr = vaxc$errno;
 602       }
 603       else {
 604         secure = 0;
 605       }
 606
 607       flags =
 608 #ifdef SECURE_INTERNAL_GETENV
 609               secure ? PERL__TRNENV_SECURE : 0
 610 #else
 611               0
 612 #endif
 613       ;
 614
 615       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 616
 617       if ((cp2 = strchr(lnm,';')) != NULL) {
 618         strcpy(buf,lnm);
 619         buf[cp2-lnm] = '\0';
 620         idx = strtoul(cp2+1,NULL,0);
 621         lnm = buf;
 622         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 623       }
 624
 625       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 626
 627       /* Get rid of "000000/ in rooted filespecs */
 628       if (*len > 7) {
 629       char * zeros;
 630         zeros = strstr(buf, "/000000/");
 631         if (zeros != NULL) {
 632           int mlen;
 633           mlen = *len - (zeros - buf) - 7;
 634           memmove(zeros, &zeros[7], mlen);
 635           *len = *len - 7;
 636           buf[*len] = '\0';
 637         }
 638       }
 639
 640       /* Discard NOLOGNAM on internal calls since we're often looking
 641        * for an optional name, and this "error" often shows up as the
 642        * (bogus) exit status for a die() call later on.  */
 643       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 644       return *len ? buf : Nullch;
 645     }
 646
 647 }  /* end of my_getenv_len() */
 648 /*}}}*/
 649
 650 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 651
 652 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 653
 654 /*{{{ void prime_env_iter() */
 655 void
 656 prime_env_iter(void)
 657 /* Fill the %ENV associative array with all logical names we can
 658  * find, in preparation for iterating over it.
 659  */
 660 {
 661   static int primed = 0;
 662   HV *seenhv = NULL, *envhv;
 663   SV *sv = NULL;
 664   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 665   unsigned short int chan;
 666 #ifndef CLI$M_TRUSTED
 667 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 668 #endif
 669   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 670   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 671   long int i;
 672   bool have_sym = FALSE, have_lnm = FALSE;
 673   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 674   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 675   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 676   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 677   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 678 #if defined(PERL_IMPLICIT_CONTEXT)
 679   pTHX;
 680 #endif
 681 #if defined(USE_ITHREADS)
 682   static perl_mutex primenv_mutex;
 683   MUTEX_INIT(&primenv_mutex);
 684 #endif
 685
 686 #if defined(PERL_IMPLICIT_CONTEXT)
 687     /* We jump through these hoops because we can be called at */
 688     /* platform-specific initialization time, which is before anything is */
 689     /* set up--we can't even do a plain dTHX since that relies on the */
 690     /* interpreter structure to be initialized */
 691     if (PL_curinterp) {
 692       aTHX = PERL_GET_INTERP;
 693     } else {
 694       aTHX = NULL;
 695     }
 696 #endif
 697
 698   if (primed || !PL_envgv) return;
 699   MUTEX_LOCK(&primenv_mutex);
 700   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 701   envhv = GvHVn(PL_envgv);
 702   /* Perform a dummy fetch as an lval to insure that the hash table is
 703    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 704   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 705
 706   for (i = 0; env_tables[i]; i++) {
 707      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 708          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 709      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 710   }
 711   if (have_sym || have_lnm) {
 712     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 713     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 714     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 715     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 716   }
 717
 718   for (i--; i >= 0; i--) {
 719     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 720       char *start;
 721       int j;
 722       for (j = 0; environ[j]; j++) {
 723         if (!(start = strchr(environ[j],'='))) {
 724           if (ckWARN(WARN_INTERNAL))
 725             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 726         }
 727         else {
 728           start++;
 729           sv = newSVpv(start,0);
 730           SvTAINTED_on(sv);
 731           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 732         }
 733       }
 734       continue;
 735     }
 736     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 737              !str$case_blind_compare(&tmpdsc,&clisym)) {
 738       strcpy(cmd,"Show Symbol/Global *");
 739       cmddsc.dsc$w_length = 20;
 740       if (env_tables[i]->dsc$w_length == 12 &&
 741           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 742           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 743       flags = defflags | CLI$M_NOLOGNAM;
 744     }
 745     else {
 746       strcpy(cmd,"Show Logical *");
 747       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 748         strcat(cmd," /Table=");
 749         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 750         cmddsc.dsc$w_length = strlen(cmd);
 751       }
 752       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 753       flags = defflags | CLI$M_NOCLISYM;
 754     }
 755
 756     /* Create a new subprocess to execute each command, to exclude the
 757      * remote possibility that someone could subvert a mbx or file used
 758      * to write multiple commands to a single subprocess.
 759      */
 760     do {
 761       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 762                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 763       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 764       defflags &= ~CLI$M_TRUSTED;
 765     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 766     _ckvmssts(retsts);
 767     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 768     if (seenhv) SvREFCNT_dec(seenhv);
 769     seenhv = newHV();
 770     while (1) {
 771       char *cp1, *cp2, *key;
 772       unsigned long int sts, iosb[2], retlen, keylen;
 773       register U32 hash;
 774
 775       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 776       if (sts & 1) sts = iosb[0] & 0xffff;
 777       if (sts == SS$_ENDOFFILE) {
 778         int wakect = 0;
 779         while (substs == 0) { sys$hiber(); wakect++;}
 780         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 781         _ckvmssts(substs);
 782         break;
 783       }
 784       _ckvmssts(sts);
 785       retlen = iosb[0] >> 16;
 786       if (!retlen) continue;  /* blank line */
 787       buf[retlen] = '\0';
 788       if (iosb[1] != subpid) {
 789         if (iosb[1]) {
 790           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 791         }
 792         continue;
 793       }
 794       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 795         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 796
 797       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 798       if (*cp1 == '(' || /* Logical name table name */
 799           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 800       if (*cp1 == '"') cp1++;
 801       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 802       key = cp1;  keylen = cp2 - cp1;
 803       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 804       while (*cp2 && *cp2 != '=') cp2++;
 805       while (*cp2 && *cp2 == '=') cp2++;
 806       while (*cp2 && *cp2 == ' ') cp2++;
 807       if (*cp2 == '"') {  /* String translation; may embed "" */
 808         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 809         cp2++;  cp1--; /* Skip "" surrounding translation */
 810       }
 811       else {  /* Numeric translation */
 812         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 813         cp1--;  /* stop on last non-space char */
 814       }
 815       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 816         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 817         continue;
 818       }
 819       PERL_HASH(hash,key,keylen);
 820
 821       if (cp1 == cp2 && *cp2 == '.') {
 822         /* A single dot usually means an unprintable character, such as a null
 823          * to indicate a zero-length value.  Get the actual value to make sure.
 824          */
 825         char lnm[LNM$C_NAMLENGTH+1];
 826         char eqv[LNM$C_NAMLENGTH+1];
 827         strncpy(lnm, key, keylen);
 828         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 829         sv = newSVpvn(eqv, strlen(eqv));
 830       }
 831       else {
 832         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 833       }
 834
 835       SvTAINTED_on(sv);
 836       hv_store(envhv,key,keylen,sv,hash);
 837       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 838     }
 839     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 840       /* get the PPFs for this process, not the subprocess */
 841       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 842       char eqv[LNM$C_NAMLENGTH+1];
 843       int trnlen, i;
 844       for (i = 0; ppfs[i]; i++) {
 845         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 846         sv = newSVpv(eqv,trnlen);
 847         SvTAINTED_on(sv);
 848         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 849       }
 850     }
 851   }
 852   primed = 1;
 853   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 854   if (buf) Safefree(buf);
 855   if (seenhv) SvREFCNT_dec(seenhv);
 856   MUTEX_UNLOCK(&primenv_mutex);
 857   return;
 858
 859 }  /* end of prime_env_iter */
 860 /*}}}*/
 861
 862
 863 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 864 /* Define or delete an element in the same "environment" as
 865  * vmstrnenv().  If an element is to be deleted, it's removed from
 866  * the first place it's found.  If it's to be set, it's set in the
 867  * place designated by the first element of the table vector.
 868  * Like setenv() returns 0 for success, non-zero on error.
 869  */
 870 int
 871 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 872 {
 873     const char *cp1;
 874     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 875     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 876     int nseg = 0, j;
 877     unsigned long int retsts, usermode = PSL$C_USER;
 878     struct itmlst_3 *ile, *ilist;
 879     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 880                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 881                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 882     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 883     $DESCRIPTOR(local,"_LOCAL");
 884
 885     if (!lnm) {
 886         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 887         return SS$_IVLOGNAM;
 888     }
 889
 890     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 891       *cp2 = _toupper(*cp1);
 892       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 893         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 894         return SS$_IVLOGNAM;
 895       }
 896     }
 897     lnmdsc.dsc$w_length = cp1 - lnm;
 898     if (!tabvec || !*tabvec) tabvec = env_tables;
 899
 900     if (!eqv) {  /* we're deleting n element */
 901       for (curtab = 0; tabvec[curtab]; curtab++) {
 902         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 903         int i;
 904           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 905             if ((cp1 = strchr(environ[i],'=')) &&
 906                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 907                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 908 #ifdef HAS_SETENV
 909               return setenv(lnm,"",1) ? vaxc$errno : 0;
 910             }
 911           }
 912           ivenv = 1; retsts = SS$_NOLOGNAM;
 913 #else
 914               if (ckWARN(WARN_INTERNAL))
 915                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 916               ivenv = 1; retsts = SS$_NOSUCHPGM;
 917               break;
 918             }
 919           }
 920 #endif
 921         }
 922         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 923                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 924           unsigned int symtype;
 925           if (tabvec[curtab]->dsc$w_length == 12 &&
 926               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 927               !str$case_blind_compare(&tmpdsc,&local))
 928             symtype = LIB$K_CLI_LOCAL_SYM;
 929           else symtype = LIB$K_CLI_GLOBAL_SYM;
 930           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 931           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 932           if (retsts == LIB$_NOSUCHSYM) continue;
 933           break;
 934         }
 935         else if (!ivlnm) {
 936           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 937           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 938           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 939           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 940           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 941         }
 942       }
 943     }
 944     else {  /* we're defining a value */
 945       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 946 #ifdef HAS_SETENV
 947         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 948 #else
 949         if (ckWARN(WARN_INTERNAL))
 950           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 951         retsts = SS$_NOSUCHPGM;
 952 #endif
 953       }
 954       else {
 955         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 956         eqvdsc.dsc$w_length  = strlen(eqv);
 957         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 958             !str$case_blind_compare(&tmpdsc,&clisym)) {
 959           unsigned int symtype;
 960           if (tabvec[0]->dsc$w_length == 12 &&
 961               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 962                !str$case_blind_compare(&tmpdsc,&local))
 963             symtype = LIB$K_CLI_LOCAL_SYM;
 964           else symtype = LIB$K_CLI_GLOBAL_SYM;
 965           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 966         }
 967         else {
 968           if (!*eqv) eqvdsc.dsc$w_length = 1;
 969           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 970
 971             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
 972             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
 973               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
 974                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
 975               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
 976               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
 977             }
 978
 979             Newx(ilist,nseg+1,struct itmlst_3);
 980             ile = ilist;
 981             if (!ile) {
 982               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
 983               return SS$_INSFMEM;
 984             }
 985             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
 986
 987             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
 988               ile->itmcode = LNM$_STRING;
 989               ile->bufadr = c;
 990               if ((j+1) == nseg) {
 991                 ile->buflen = strlen(c);
 992                 /* in case we are truncating one that's too long */
 993                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
 994               }
 995               else {
 996                 ile->buflen = LNM$C_NAMLENGTH;
 997               }
 998             }
 999
1000             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1001             Safefree (ilist);
1002           }
1003           else {
1004             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1005           }
1006         }
1007       }
1008     }
1009     if (!(retsts & 1)) {
1010       switch (retsts) {
1011         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1012         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1013           set_errno(EVMSERR); break;
1014         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1015         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1016           set_errno(EINVAL); break;
1017         case SS$_NOPRIV:
1018           set_errno(EACCES);
1019         default:
1020           _ckvmssts(retsts);
1021           set_errno(EVMSERR);
1022        }
1023        set_vaxc_errno(retsts);
1024        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1025     }
1026     else {
1027       /* We reset error values on success because Perl does an hv_fetch()
1028        * before each hv_store(), and if the thing we're setting didn't
1029        * previously exist, we've got a leftover error message.  (Of course,
1030        * this fails in the face of
1031        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1032        * in that the error reported in $! isn't spurious,
1033        * but it's right more often than not.)
1034        */
1035       set_errno(0); set_vaxc_errno(retsts);
1036       return 0;
1037     }
1038
1039 }  /* end of vmssetenv() */
1040 /*}}}*/
1041
1042 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1043 /* This has to be a function since there's a prototype for it in proto.h */
1044 void
1045 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1046 {
1047     if (lnm && *lnm) {
1048       int len = strlen(lnm);
1049       if  (len == 7) {
1050         char uplnm[8];
1051         int i;
1052         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1053         if (!strcmp(uplnm,"DEFAULT")) {
1054           if (eqv && *eqv) chdir(eqv);
1055           return;
1056         }
1057     }
1058 #ifndef RTL_USES_UTC
1059     if (len == 6 || len == 2) {
1060       char uplnm[7];
1061       int i;
1062       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1063       uplnm[len] = '\0';
1064       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1065       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1066     }
1067 #endif
1068   }
1069   (void) vmssetenv(lnm,eqv,NULL);
1070 }
1071 /*}}}*/
1072
1073 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1074 /*  vmssetuserlnm
1075  *  sets a user-mode logical in the process logical name table
1076  *  used for redirection of sys$error
1077  */
1078 void
1079 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1080 {
1081     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1082     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1083     unsigned long int iss, attr = LNM$M_CONFINE;
1084     unsigned char acmode = PSL$C_USER;
1085     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1086                                  {0, 0, 0, 0}};
1087     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1088     d_name.dsc$w_length = strlen(name);
1089
1090     lnmlst[0].buflen = strlen(eqv);
1091     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1092
1093     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1094     if (!(iss&1)) lib$signal(iss);
1095 }
1096 /*}}}*/
1097
1098
1099 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1100 /* my_crypt - VMS password hashing
1101  * my_crypt() provides an interface compatible with the Unix crypt()
1102  * C library function, and uses sys$hash_password() to perform VMS
1103  * password hashing.  The quadword hashed password value is returned
1104  * as a NUL-terminated 8 character string.  my_crypt() does not change
1105  * the case of its string arguments; in order to match the behavior
1106  * of LOGINOUT et al., alphabetic characters in both arguments must
1107  *  be upcased by the caller.
1108  */
1109 char *
1110 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1111 {
1112 #   ifndef UAI$C_PREFERRED_ALGORITHM
1113 #     define UAI$C_PREFERRED_ALGORITHM 127
1114 #   endif
1115     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1116     unsigned short int salt = 0;
1117     unsigned long int sts;
1118     struct const_dsc {
1119         unsigned short int dsc$w_length;
1120         unsigned char      dsc$b_type;
1121         unsigned char      dsc$b_class;
1122         const char *       dsc$a_pointer;
1123     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1124        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1125     struct itmlst_3 uailst[3] = {
1126         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1127         { sizeof salt, UAI$_SALT,    &salt, 0},
1128         { 0,           0,            NULL,  NULL}};
1129     static char hash[9];
1130
1131     usrdsc.dsc$w_length = strlen(usrname);
1132     usrdsc.dsc$a_pointer = usrname;
1133     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1134       switch (sts) {
1135         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1136           set_errno(EACCES);
1137           break;
1138         case RMS$_RNF:
1139           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1140           break;
1141         default:
1142           set_errno(EVMSERR);
1143       }
1144       set_vaxc_errno(sts);
1145       if (sts != RMS$_RNF) return NULL;
1146     }
1147
1148     txtdsc.dsc$w_length = strlen(textpasswd);
1149     txtdsc.dsc$a_pointer = textpasswd;
1150     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1151       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1152     }
1153
1154     return (char *) hash;
1155
1156 }  /* end of my_crypt() */
1157 /*}}}*/
1158
1159
1160 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1161 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1162 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1163
1164 /*{{{int do_rmdir(char *name)*/
1165 int
1166 Perl_do_rmdir(pTHX_ const char *name)
1167 {
1168     char dirfile[NAM$C_MAXRSS+1];
1169     int retval;
1170     Stat_t st;
1171
1172     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1173     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1174     else retval = kill_file(dirfile);
1175     return retval;
1176
1177 }  /* end of do_rmdir */
1178 /*}}}*/
1179
1180 /* kill_file
1181  * Delete any file to which user has control access, regardless of whether
1182  * delete access is explicitly allowed.
1183  * Limitations: User must have write access to parent directory.
1184  *              Does not block signals or ASTs; if interrupted in midstream
1185  *              may leave file with an altered ACL.
1186  * HANDLE WITH CARE!
1187  */
1188 /*{{{int kill_file(char *name)*/
1189 int
1190 Perl_kill_file(pTHX_ const char *name)
1191 {
1192     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1193     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1194     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1195     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1196     struct myacedef {
1197       unsigned char myace$b_length;
1198       unsigned char myace$b_type;
1199       unsigned short int myace$w_flags;
1200       unsigned long int myace$l_access;
1201       unsigned long int myace$l_ident;
1202     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1203                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1204       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1205      struct itmlst_3
1206        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1207                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1208        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1209        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1210        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1211        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1212
1213     /* Expand the input spec using RMS, since the CRTL remove() and
1214      * system services won't do this by themselves, so we may miss
1215      * a file "hiding" behind a logical name or search list. */
1216     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1217     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1218     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1219     /* If not, can changing protections help? */
1220     if (vaxc$errno != RMS$_PRV) return -1;
1221
1222     /* No, so we get our own UIC to use as a rights identifier,
1223      * and the insert an ACE at the head of the ACL which allows us
1224      * to delete the file.
1225      */
1226     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1227     fildsc.dsc$w_length = strlen(rspec);
1228     fildsc.dsc$a_pointer = rspec;
1229     cxt = 0;
1230     newace.myace$l_ident = oldace.myace$l_ident;
1231     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1232       switch (aclsts) {
1233         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1234           set_errno(ENOENT); break;
1235         case RMS$_DIR:
1236           set_errno(ENOTDIR); break;
1237         case RMS$_DEV:
1238           set_errno(ENODEV); break;
1239         case RMS$_SYN: case SS$_INVFILFOROP:
1240           set_errno(EINVAL); break;
1241         case RMS$_PRV:
1242           set_errno(EACCES); break;
1243         default:
1244           _ckvmssts(aclsts);
1245       }
1246       set_vaxc_errno(aclsts);
1247       return -1;
1248     }
1249     /* Grab any existing ACEs with this identifier in case we fail */
1250     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1251     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1252                     || fndsts == SS$_NOMOREACE ) {
1253       /* Add the new ACE . . . */
1254       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1255         goto yourroom;
1256       if ((rmsts = remove(name))) {
1257         /* We blew it - dir with files in it, no write priv for
1258          * parent directory, etc.  Put things back the way they were. */
1259         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1260           goto yourroom;
1261         if (fndsts & 1) {
1262           addlst[0].bufadr = &oldace;
1263           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1264             goto yourroom;
1265         }
1266       }
1267     }
1268
1269     yourroom:
1270     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1271     /* We just deleted it, so of course it's not there.  Some versions of
1272      * VMS seem to return success on the unlock operation anyhow (after all
1273      * the unlock is successful), but others don't.
1274      */
1275     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1276     if (aclsts & 1) aclsts = fndsts;
1277     if (!(aclsts & 1)) {
1278       set_errno(EVMSERR);
1279       set_vaxc_errno(aclsts);
1280       return -1;
1281     }
1282
1283     return rmsts;
1284
1285 }  /* end of kill_file() */
1286 /*}}}*/
1287
1288
1289 /*{{{int my_mkdir(char *,Mode_t)*/
1290 int
1291 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1292 {
1293   STRLEN dirlen = strlen(dir);
1294
1295   /* zero length string sometimes gives ACCVIO */
1296   if (dirlen == 0) return -1;
1297
1298   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1299    * null file name/type.  However, it's commonplace under Unix,
1300    * so we'll allow it for a gain in portability.
1301    */
1302   if (dir[dirlen-1] == '/') {
1303     char *newdir = savepvn(dir,dirlen-1);
1304     int ret = mkdir(newdir,mode);
1305     Safefree(newdir);
1306     return ret;
1307   }
1308   else return mkdir(dir,mode);
1309 }  /* end of my_mkdir */
1310 /*}}}*/
1311
1312 /*{{{int my_chdir(char *)*/
1313 int
1314 Perl_my_chdir(pTHX_ const char *dir)
1315 {
1316   STRLEN dirlen = strlen(dir);
1317
1318   /* zero length string sometimes gives ACCVIO */
1319   if (dirlen == 0) return -1;
1320   const char *dir1;
1321
1322   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1323    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1324    * so that existing scripts do not need to be changed.
1325    */
1326   dir1 = dir;
1327   while ((dirlen > 0) && (*dir1 == ' ')) {
1328     dir1++;
1329     dirlen--;
1330   }
1331
1332   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1333    * that implies
1334    * null file name/type.  However, it's commonplace under Unix,
1335    * so we'll allow it for a gain in portability.
1336    *
1337    * - Preview- '/' will be valid soon on VMS
1338    */
1339   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1340     char *newdir = savepvn(dir,dirlen-1);
1341     int ret = chdir(newdir);
1342     Safefree(newdir);
1343     return ret;
1344   }
1345   else return chdir(dir);
1346 }  /* end of my_chdir */
1347 /*}}}*/
1348
1349
1350 /*{{{FILE *my_tmpfile()*/
1351 FILE *
1352 my_tmpfile(void)
1353 {
1354   FILE *fp;
1355   char *cp;
1356
1357   if ((fp = tmpfile())) return fp;
1358
1359   Newx(cp,L_tmpnam+24,char);
1360   strcpy(cp,"Sys$Scratch:");
1361   tmpnam(cp+strlen(cp));
1362   strcat(cp,".Perltmp");
1363   fp = fopen(cp,"w+","fop=dlt");
1364   Safefree(cp);
1365   return fp;
1366 }
1367 /*}}}*/
1368
1369
1370 #ifndef HOMEGROWN_POSIX_SIGNALS
1371 /*
1372  * The C RTL's sigaction fails to check for invalid signal numbers so we
1373  * help it out a bit.  The docs are correct, but the actual routine doesn't
1374  * do what the docs say it will.
1375  */
1376 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1377 int
1378 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1379                    struct sigaction* oact)
1380 {
1381   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1382         SETERRNO(EINVAL, SS$_INVARG);
1383         return -1;
1384   }
1385   return sigaction(sig, act, oact);
1386 }
1387 /*}}}*/
1388 #endif
1389
1390 #ifdef KILL_BY_SIGPRC
1391 #include <errnodef.h>
1392
1393 /* We implement our own kill() using the undocumented system service
1394    sys$sigprc for one of two reasons:
1395
1396    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1397    target process to do a sys$exit, which usually can't be handled
1398    gracefully...certainly not by Perl and the %SIG{} mechanism.
1399
1400    2.) If the kill() in the CRTL can't be called from a signal
1401    handler without disappearing into the ether, i.e., the signal
1402    it purportedly sends is never trapped. Still true as of VMS 7.3.
1403
1404    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1405    in the target process rather than calling sys$exit.
1406
1407    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1408    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1409    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1410    with condition codes C$_SIG0+nsig*8, catching the exception on the
1411    target process and resignaling with appropriate arguments.
1412
1413    But we don't have that VMS 7.0+ exception handler, so if you
1414    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1415
1416    Also note that SIGTERM is listed in the docs as being "unimplemented",
1417    yet always seems to be signaled with a VMS condition code of 4 (and
1418    correctly handled for that code).  So we hardwire it in.
1419
1420    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1421    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1422    than signalling with an unrecognized (and unhandled by CRTL) code.
1423 */
1424
1425 #define _MY_SIG_MAX 17
1426
1427 unsigned int
1428 Perl_sig_to_vmscondition(int sig)
1429 {
1430     static unsigned int sig_code[_MY_SIG_MAX+1] =
1431     {
1432         0,                  /*  0 ZERO     */
1433         SS$_HANGUP,         /*  1 SIGHUP   */
1434         SS$_CONTROLC,       /*  2 SIGINT   */
1435         SS$_CONTROLY,       /*  3 SIGQUIT  */
1436         SS$_RADRMOD,        /*  4 SIGILL   */
1437         SS$_BREAK,          /*  5 SIGTRAP  */
1438         SS$_OPCCUS,         /*  6 SIGABRT  */
1439         SS$_COMPAT,         /*  7 SIGEMT   */
1440 #ifdef __VAX
1441         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1442 #else
1443         SS$_HPARITH,        /*  8 SIGFPE AXP */
1444 #endif
1445         SS$_ABORT,          /*  9 SIGKILL  */
1446         SS$_ACCVIO,         /* 10 SIGBUS   */
1447         SS$_ACCVIO,         /* 11 SIGSEGV  */
1448         SS$_BADPARAM,       /* 12 SIGSYS   */
1449         SS$_NOMBX,          /* 13 SIGPIPE  */
1450         SS$_ASTFLT,         /* 14 SIGALRM  */
1451         4,                  /* 15 SIGTERM  */
1452         0,                  /* 16 SIGUSR1  */
1453         0                   /* 17 SIGUSR2  */
1454     };
1455
1456 #if __VMS_VER >= 60200000
1457     static int initted = 0;
1458     if (!initted) {
1459         initted = 1;
1460         sig_code[16] = C$_SIGUSR1;
1461         sig_code[17] = C$_SIGUSR2;
1462     }
1463 #endif
1464
1465     if (sig < _SIG_MIN) return 0;
1466     if (sig > _MY_SIG_MAX) return 0;
1467     return sig_code[sig];
1468 }
1469
1470 int
1471 Perl_my_kill(int pid, int sig)
1472 {
1473     dTHX;
1474     int iss;
1475     unsigned int code;
1476     int sys$sigprc(unsigned int *pidadr,
1477                      struct dsc$descriptor_s *prcname,
1478                      unsigned int code);
1479
1480     code = Perl_sig_to_vmscondition(sig);
1481
1482     if (!pid || !code) {
1483         return -1;
1484     }
1485
1486     iss = sys$sigprc((unsigned int *)&pid,0,code);
1487     if (iss&1) return 0;
1488
1489     switch (iss) {
1490       case SS$_NOPRIV:
1491         set_errno(EPERM);  break;
1492       case SS$_NONEXPR:
1493       case SS$_NOSUCHNODE:
1494       case SS$_UNREACHABLE:
1495         set_errno(ESRCH);  break;
1496       case SS$_INSFMEM:
1497         set_errno(ENOMEM); break;
1498       default:
1499         _ckvmssts(iss);
1500         set_errno(EVMSERR);
1501     }
1502     set_vaxc_errno(iss);
1503
1504     return -1;
1505 }
1506 #endif
1507
1508 /* Routine to convert a VMS status code to a UNIX status code.
1509 ** More tricky than it appears because of conflicting conventions with
1510 ** existing code.
1511 **
1512 ** VMS status codes are a bit mask, with the least significant bit set for
1513 ** success.
1514 **
1515 ** Special UNIX status of EVMSERR indicates that no translation is currently
1516 ** available, and programs should check the VMS status code.
1517 **
1518 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1519 ** decoding.
1520 */
1521
1522 #ifndef C_FACILITY_NO
1523 #define C_FACILITY_NO 0x350000
1524 #endif
1525 #ifndef DCL_IVVERB
1526 #define DCL_IVVERB 0x38090
1527 #endif
1528
1529 int vms_status_to_unix(int vms_status)
1530 {
1531 int facility;
1532 int fac_sp;
1533 int msg_no;
1534 int msg_status;
1535 int unix_status;
1536
1537   /* Assume the best or the worst */
1538   if (vms_status & STS$M_SUCCESS)
1539     unix_status = 0;
1540   else
1541     unix_status = EVMSERR;
1542
1543   msg_status = vms_status & ~STS$M_CONTROL;
1544
1545   facility = vms_status & STS$M_FAC_NO;
1546   fac_sp = vms_status & STS$M_FAC_SP;
1547   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1548
1549   if ((facility == 0) || (fac_sp == 0)) {
1550     switch(msg_no) {
1551     case SS$_NORMAL:
1552         unix_status = 0;
1553         break;
1554     case SS$_ACCVIO:
1555         unix_status = EFAULT;
1556         break;
1557     case SS$_IVLOGNAM:
1558     case SS$_BADPARAM:
1559     case SS$_IVLOGTAB:
1560     case SS$_NOLOGNAM:
1561     case SS$_NOLOGTAB:
1562     case SS$_INVFILFOROP:
1563     case SS$_INVARG:
1564     case SS$_NOSUCHID:
1565     case SS$_IVIDENT:
1566         unix_status = EINVAL;
1567         break;
1568     case SS$_FILACCERR:
1569     case SS$_NOGRPPRV:
1570     case SS$_NOSYSPRV:
1571         unix_status = EACCES;
1572         break;
1573     case SS$_DEVICEFULL:
1574         unix_status = ENOSPC;
1575         break;
1576     case SS$_NOSUCHDEV:
1577         unix_status = ENODEV;
1578         break;
1579     case SS$_NOSUCHFILE:
1580     case SS$_NOSUCHOBJECT:
1581         unix_status = ENOENT;
1582         break;
1583     case SS$_ABORT:
1584         unix_status = EINTR;
1585         break;
1586     case SS$_BUFFEROVF:
1587         unix_status = E2BIG;
1588         break;
1589     case SS$_INSFMEM:
1590         unix_status = ENOMEM;
1591         break;
1592     case SS$_NOPRIV:
1593         unix_status = EPERM;
1594         break;
1595     case SS$_NOSUCHNODE:
1596     case SS$_UNREACHABLE:
1597         unix_status = ESRCH;
1598         break;
1599     case SS$_NONEXPR:
1600         unix_status = ECHILD;
1601         break;
1602     default:
1603         if ((facility == 0) && (msg_no < 8)) {
1604           /* These are not real VMS status codes so assume that they are
1605           ** already UNIX status codes
1606           */
1607           unix_status = msg_no;
1608           break;
1609         }
1610     }
1611   }
1612   else {
1613     /* Translate a POSIX exit code to a UNIX exit code */
1614     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1615         unix_status = (msg_no & 0x0FF0) >> 3;
1616     }
1617     else {
1618         switch(msg_status) {
1619         /* case RMS$_EOF: */ /* End of File */
1620         case RMS$_FNF:  /* File Not Found */
1621         case RMS$_DNF:  /* Dir Not Found */
1622                 unix_status = ENOENT;
1623                 break;
1624         case RMS$_RNF:  /* Record Not Found */
1625                 unix_status = ESRCH;
1626                 break;
1627         case RMS$_DIR:
1628                 unix_status = ENOTDIR;
1629                 break;
1630         case RMS$_DEV:
1631                 unix_status = ENODEV;
1632                 break;
1633         case RMS$_SYN:
1634         case RMS$_FNM:
1635         case LIB$_INVSTRDES:
1636         case LIB$_INVARG:
1637         case LIB$_NOSUCHSYM:
1638         case LIB$_INVSYMNAM:
1639         case DCL_IVVERB:
1640                 unix_status = EINVAL;
1641                 break;
1642         case CLI$_BUFOVF:
1643         case RMS$_RTB:
1644         case CLI$_TKNOVF:
1645         case CLI$_RSLOVF:
1646                 unix_status = E2BIG;
1647                 break;
1648         case RMS$_PRV:  /* No privilege */
1649         case RMS$_ACC:  /* ACP file access failed */
1650         case RMS$_WLK:  /* Device write locked */
1651                 unix_status = EACCES;
1652                 break;
1653         /* case RMS$_NMF: */  /* No more files */
1654         }
1655     }
1656   }
1657
1658   return unix_status;
1659 }
1660
1661
1662
1663 /* default piping mailbox size */
1664 #define PERL_BUFSIZ        512
1665
1666
1667 static void
1668 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1669 {
1670   unsigned long int mbxbufsiz;
1671   static unsigned long int syssize = 0;
1672   unsigned long int dviitm = DVI$_DEVNAM;
1673   char csize[LNM$C_NAMLENGTH+1];
1674   int sts;
1675
1676   if (!syssize) {
1677     unsigned long syiitm = SYI$_MAXBUF;
1678     /*
1679      * Get the SYSGEN parameter MAXBUF
1680      *
1681      * If the logical 'PERL_MBX_SIZE' is defined
1682      * use the value of the logical instead of PERL_BUFSIZ, but
1683      * keep the size between 128 and MAXBUF.
1684      *
1685      */
1686     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1687   }
1688
1689   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1690       mbxbufsiz = atoi(csize);
1691   } else {
1692       mbxbufsiz = PERL_BUFSIZ;
1693   }
1694   if (mbxbufsiz < 128) mbxbufsiz = 128;
1695   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1696
1697   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1698
1699   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1700   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1701
1702 }  /* end of create_mbx() */
1703
1704
1705 /*{{{  my_popen and my_pclose*/
1706
1707 typedef struct _iosb           IOSB;
1708 typedef struct _iosb*         pIOSB;
1709 typedef struct _pipe           Pipe;
1710 typedef struct _pipe*         pPipe;
1711 typedef struct pipe_details    Info;
1712 typedef struct pipe_details*  pInfo;
1713 typedef struct _srqp            RQE;
1714 typedef struct _srqp*          pRQE;
1715 typedef struct _tochildbuf      CBuf;
1716 typedef struct _tochildbuf*    pCBuf;
1717
1718 struct _iosb {
1719     unsigned short status;
1720     unsigned short count;
1721     unsigned long  dvispec;
1722 };
1723
1724 #pragma member_alignment save
1725 #pragma nomember_alignment quadword
1726 struct _srqp {          /* VMS self-relative queue entry */
1727     unsigned long qptr[2];
1728 };
1729 #pragma member_alignment restore
1730 static RQE  RQE_ZERO = {0,0};
1731
1732 struct _tochildbuf {
1733     RQE             q;
1734     int             eof;
1735     unsigned short  size;
1736     char            *buf;
1737 };
1738
1739 struct _pipe {
1740     RQE            free;
1741     RQE            wait;
1742     int            fd_out;
1743     unsigned short chan_in;
1744     unsigned short chan_out;
1745     char          *buf;
1746     unsigned int   bufsize;
1747     IOSB           iosb;
1748     IOSB           iosb2;
1749     int           *pipe_done;
1750     int            retry;
1751     int            type;
1752     int            shut_on_empty;
1753     int            need_wake;
1754     pPipe         *home;
1755     pInfo          info;
1756     pCBuf          curr;
1757     pCBuf          curr2;
1758 #if defined(PERL_IMPLICIT_CONTEXT)
1759     void            *thx;           /* Either a thread or an interpreter */
1760                                     /* pointer, depending on how we're built */
1761 #endif
1762 };
1763
1764
1765 struct pipe_details
1766 {
1767     pInfo           next;
1768     PerlIO *fp;  /* file pointer to pipe mailbox */
1769     int useFILE; /* using stdio, not perlio */
1770     int pid;   /* PID of subprocess */
1771     int mode;  /* == 'r' if pipe open for reading */
1772     int done;  /* subprocess has completed */
1773     int waiting; /* waiting for completion/closure */
1774     int             closing;        /* my_pclose is closing this pipe */
1775     unsigned long   completion;     /* termination status of subprocess */
1776     pPipe           in;             /* pipe in to sub */
1777     pPipe           out;            /* pipe out of sub */
1778     pPipe           err;            /* pipe of sub's sys$error */
1779     int             in_done;        /* true when in pipe finished */
1780     int             out_done;
1781     int             err_done;
1782 };
1783
1784 struct exit_control_block
1785 {
1786     struct exit_control_block *flink;
1787     unsigned long int   (*exit_routine)();
1788     unsigned long int arg_count;
1789     unsigned long int *status_address;
1790     unsigned long int exit_status;
1791 };
1792
1793 typedef struct _closed_pipes    Xpipe;
1794 typedef struct _closed_pipes*  pXpipe;
1795
1796 struct _closed_pipes {
1797     int             pid;            /* PID of subprocess */
1798     unsigned long   completion;     /* termination status of subprocess */
1799 };
1800 #define NKEEPCLOSED 50
1801 static Xpipe closed_list[NKEEPCLOSED];
1802 static int   closed_index = 0;
1803 static int   closed_num = 0;
1804
1805 #define RETRY_DELAY     "0 ::0.20"
1806 #define MAX_RETRY              50
1807
1808 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1809 static unsigned long mypid;
1810 static unsigned long delaytime[2];
1811
1812 static pInfo open_pipes = NULL;
1813 static $DESCRIPTOR(nl_desc, "NL:");
1814
1815 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
1816
1817
1818
1819 static unsigned long int
1820 pipe_exit_routine(pTHX)
1821 {
1822     pInfo info;
1823     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1824     int sts, did_stuff, need_eof, j;
1825
1826     /*
1827         flush any pending i/o
1828     */
1829     info = open_pipes;
1830     while (info) {
1831         if (info->fp) {
1832            if (!info->useFILE)
1833                PerlIO_flush(info->fp);   /* first, flush data */
1834            else
1835                fflush((FILE *)info->fp);
1836         }
1837         info = info->next;
1838     }
1839
1840     /*
1841      next we try sending an EOF...ignore if doesn't work, make sure we
1842      don't hang
1843     */
1844     did_stuff = 0;
1845     info = open_pipes;
1846
1847     while (info) {
1848       int need_eof;
1849       _ckvmssts(sys$setast(0));
1850       if (info->in && !info->in->shut_on_empty) {
1851         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1852                           0, 0, 0, 0, 0, 0));
1853         info->waiting = 1;
1854         did_stuff = 1;
1855       }
1856       _ckvmssts(sys$setast(1));
1857       info = info->next;
1858     }
1859
1860     /* wait for EOF to have effect, up to ~ 30 sec [default] */
1861
1862     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1863         int nwait = 0;
1864
1865         info = open_pipes;
1866         while (info) {
1867           _ckvmssts(sys$setast(0));
1868           if (info->waiting && info->done)
1869                 info->waiting = 0;
1870           nwait += info->waiting;
1871           _ckvmssts(sys$setast(1));
1872           info = info->next;
1873         }
1874         if (!nwait) break;
1875         sleep(1);
1876     }
1877
1878     did_stuff = 0;
1879     info = open_pipes;
1880     while (info) {
1881       _ckvmssts(sys$setast(0));
1882       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1883         sts = sys$forcex(&info->pid,0,&abort);
1884         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1885         did_stuff = 1;
1886       }
1887       _ckvmssts(sys$setast(1));
1888       info = info->next;
1889     }
1890
1891     /* again, wait for effect */
1892
1893     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1894         int nwait = 0;
1895
1896         info = open_pipes;
1897         while (info) {
1898           _ckvmssts(sys$setast(0));
1899           if (info->waiting && info->done)
1900                 info->waiting = 0;
1901           nwait += info->waiting;
1902           _ckvmssts(sys$setast(1));
1903           info = info->next;
1904         }
1905         if (!nwait) break;
1906         sleep(1);
1907     }
1908
1909     info = open_pipes;
1910     while (info) {
1911       _ckvmssts(sys$setast(0));
1912       if (!info->done) {  /* We tried to be nice . . . */
1913         sts = sys$delprc(&info->pid,0);
1914         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1915       }
1916       _ckvmssts(sys$setast(1));
1917       info = info->next;
1918     }
1919
1920     while(open_pipes) {
1921       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1922       else if (!(sts & 1)) retsts = sts;
1923     }
1924     return retsts;
1925 }
1926
1927 static struct exit_control_block pipe_exitblock =
1928        {(struct exit_control_block *) 0,
1929         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1930
1931 static void pipe_mbxtofd_ast(pPipe p);
1932 static void pipe_tochild1_ast(pPipe p);
1933 static void pipe_tochild2_ast(pPipe p);
1934
1935 static void
1936 popen_completion_ast(pInfo info)
1937 {
1938   pInfo i = open_pipes;
1939   int iss;
1940   int sts;
1941   pXpipe x;
1942
1943   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1944   closed_list[closed_index].pid = info->pid;
1945   closed_list[closed_index].completion = info->completion;
1946   closed_index++;
1947   if (closed_index == NKEEPCLOSED)
1948     closed_index = 0;
1949   closed_num++;
1950
1951   while (i) {
1952     if (i == info) break;
1953     i = i->next;
1954   }
1955   if (!i) return;       /* unlinked, probably freed too */
1956
1957   info->done = TRUE;
1958
1959 /*
1960     Writing to subprocess ...
1961             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1962
1963             chan_out may be waiting for "done" flag, or hung waiting
1964             for i/o completion to child...cancel the i/o.  This will
1965             put it into "snarf mode" (done but no EOF yet) that discards
1966             input.
1967
1968     Output from subprocess (stdout, stderr) needs to be flushed and
1969     shut down.   We try sending an EOF, but if the mbx is full the pipe
1970     routine should still catch the "shut_on_empty" flag, telling it to
1971     use immediate-style reads so that "mbx empty" -> EOF.
1972
1973
1974 */
1975   if (info->in && !info->in_done) {               /* only for mode=w */
1976         if (info->in->shut_on_empty && info->in->need_wake) {
1977             info->in->need_wake = FALSE;
1978             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1979         } else {
1980             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1981         }
1982   }
1983
1984   if (info->out && !info->out_done) {             /* were we also piping output? */
1985       info->out->shut_on_empty = TRUE;
1986       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1987       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1988       _ckvmssts_noperl(iss);
1989   }
1990
1991   if (info->err && !info->err_done) {        /* we were piping stderr */
1992         info->err->shut_on_empty = TRUE;
1993         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1994         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1995         _ckvmssts_noperl(iss);
1996   }
1997   _ckvmssts_noperl(sys$setef(pipe_ef));
1998
1999 }
2000
2001 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2002 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2003
2004 /*
2005     we actually differ from vmstrnenv since we use this to
2006     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2007     are pointing to the same thing
2008 */
2009
2010 static unsigned short
2011 popen_translate(pTHX_ char *logical, char *result)
2012 {
2013     int iss;
2014     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2015     $DESCRIPTOR(d_log,"");
2016     struct _il3 {
2017         unsigned short length;
2018         unsigned short code;
2019         char *         buffer_addr;
2020         unsigned short *retlenaddr;
2021     } itmlst[2];
2022     unsigned short l, ifi;
2023
2024     d_log.dsc$a_pointer = logical;
2025     d_log.dsc$w_length  = strlen(logical);
2026
2027     itmlst[0].code = LNM$_STRING;
2028     itmlst[0].length = 255;
2029     itmlst[0].buffer_addr = result;
2030     itmlst[0].retlenaddr = &l;
2031
2032     itmlst[1].code = 0;
2033     itmlst[1].length = 0;
2034     itmlst[1].buffer_addr = 0;
2035     itmlst[1].retlenaddr = 0;
2036
2037     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2038     if (iss == SS$_NOLOGNAM) {
2039         iss = SS$_NORMAL;
2040         l = 0;
2041     }
2042     if (!(iss&1)) lib$signal(iss);
2043     result[l] = '\0';
2044 /*
2045     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2046     strip it off and return the ifi, if any
2047 */
2048     ifi  = 0;
2049     if (result[0] == 0x1b && result[1] == 0x00) {
2050         memcpy(&ifi,result+2,2);
2051         strcpy(result,result+4);
2052     }
2053     return ifi;     /* this is the RMS internal file id */
2054 }
2055
2056 static void pipe_infromchild_ast(pPipe p);
2057
2058 /*
2059     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2060     inside an AST routine without worrying about reentrancy and which Perl
2061     memory allocator is being used.
2062
2063     We read data and queue up the buffers, then spit them out one at a
2064     time to the output mailbox when the output mailbox is ready for one.
2065
2066 */
2067 #define INITIAL_TOCHILDQUEUE  2
2068
2069 static pPipe
2070 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2071 {
2072     pPipe p;
2073     pCBuf b;
2074     char mbx1[64], mbx2[64];
2075     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2076                                       DSC$K_CLASS_S, mbx1},
2077                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2078                                       DSC$K_CLASS_S, mbx2};
2079     unsigned int dviitm = DVI$_DEVBUFSIZ;
2080     int j, n;
2081
2082     Newx(p, 1, Pipe);
2083
2084     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2085     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2086     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2087
2088     p->buf           = 0;
2089     p->shut_on_empty = FALSE;
2090     p->need_wake     = FALSE;
2091     p->type          = 0;
2092     p->retry         = 0;
2093     p->iosb.status   = SS$_NORMAL;
2094     p->iosb2.status  = SS$_NORMAL;
2095     p->free          = RQE_ZERO;
2096     p->wait          = RQE_ZERO;
2097     p->curr          = 0;
2098     p->curr2         = 0;
2099     p->info          = 0;
2100 #ifdef PERL_IMPLICIT_CONTEXT
2101     p->thx           = aTHX;
2102 #endif
2103
2104     n = sizeof(CBuf) + p->bufsize;
2105
2106     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2107         _ckvmssts(lib$get_vm(&n, &b));
2108         b->buf = (char *) b + sizeof(CBuf);
2109         _ckvmssts(lib$insqhi(b, &p->free));
2110     }
2111
2112     pipe_tochild2_ast(p);
2113     pipe_tochild1_ast(p);
2114     strcpy(wmbx, mbx1);
2115     strcpy(rmbx, mbx2);
2116     return p;
2117 }
2118
2119 /*  reads the MBX Perl is writing, and queues */
2120
2121 static void
2122 pipe_tochild1_ast(pPipe p)
2123 {
2124     pCBuf b = p->curr;
2125     int iss = p->iosb.status;
2126     int eof = (iss == SS$_ENDOFFILE);
2127     int sts;
2128 #ifdef PERL_IMPLICIT_CONTEXT
2129     pTHX = p->thx;
2130 #endif
2131
2132     if (p->retry) {
2133         if (eof) {
2134             p->shut_on_empty = TRUE;
2135             b->eof     = TRUE;
2136             _ckvmssts(sys$dassgn(p->chan_in));
2137         } else  {
2138             _ckvmssts(iss);
2139         }
2140
2141         b->eof  = eof;
2142         b->size = p->iosb.count;
2143         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2144         if (p->need_wake) {
2145             p->need_wake = FALSE;
2146             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2147         }
2148     } else {
2149         p->retry = 1;   /* initial call */
2150     }
2151
2152     if (eof) {                  /* flush the free queue, return when done */
2153         int n = sizeof(CBuf) + p->bufsize;
2154         while (1) {
2155             iss = lib$remqti(&p->free, &b);
2156             if (iss == LIB$_QUEWASEMP) return;
2157             _ckvmssts(iss);
2158             _ckvmssts(lib$free_vm(&n, &b));
2159         }
2160     }
2161
2162     iss = lib$remqti(&p->free, &b);
2163     if (iss == LIB$_QUEWASEMP) {
2164         int n = sizeof(CBuf) + p->bufsize;
2165         _ckvmssts(lib$get_vm(&n, &b));
2166         b->buf = (char *) b + sizeof(CBuf);
2167     } else {
2168        _ckvmssts(iss);
2169     }
2170
2171     p->curr = b;
2172     iss = sys$qio(0,p->chan_in,
2173              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2174              &p->iosb,
2175              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2176     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2177     _ckvmssts(iss);
2178 }
2179
2180
2181 /* writes queued buffers to output, waits for each to complete before
2182    doing the next */
2183
2184 static void
2185 pipe_tochild2_ast(pPipe p)
2186 {
2187     pCBuf b = p->curr2;
2188     int iss = p->iosb2.status;
2189     int n = sizeof(CBuf) + p->bufsize;
2190     int done = (p->info && p->info->done) ||
2191               iss == SS$_CANCEL || iss == SS$_ABORT;
2192 #if defined(PERL_IMPLICIT_CONTEXT)
2193     pTHX = p->thx;
2194 #endif
2195
2196     do {
2197         if (p->type) {         /* type=1 has old buffer, dispose */
2198             if (p->shut_on_empty) {
2199                 _ckvmssts(lib$free_vm(&n, &b));
2200             } else {
2201                 _ckvmssts(lib$insqhi(b, &p->free));
2202             }
2203             p->type = 0;
2204         }
2205
2206         iss = lib$remqti(&p->wait, &b);
2207         if (iss == LIB$_QUEWASEMP) {
2208             if (p->shut_on_empty) {
2209                 if (done) {
2210                     _ckvmssts(sys$dassgn(p->chan_out));
2211                     *p->pipe_done = TRUE;
2212                     _ckvmssts(sys$setef(pipe_ef));
2213                 } else {
2214                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2215                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2216                 }
2217                 return;
2218             }
2219             p->need_wake = TRUE;
2220             return;
2221         }
2222         _ckvmssts(iss);
2223         p->type = 1;
2224     } while (done);
2225
2226
2227     p->curr2 = b;
2228     if (b->eof) {
2229         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2230             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2231     } else {
2232         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2233             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2234     }
2235
2236     return;
2237
2238 }
2239
2240
2241 static pPipe
2242 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2243 {
2244     pPipe p;
2245     char mbx1[64], mbx2[64];
2246     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2247                                       DSC$K_CLASS_S, mbx1},
2248                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2249                                       DSC$K_CLASS_S, mbx2};
2250     unsigned int dviitm = DVI$_DEVBUFSIZ;
2251
2252     Newx(p, 1, Pipe);
2253     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2254     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2255
2256     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2257     Newx(p->buf, p->bufsize, char);
2258     p->shut_on_empty = FALSE;
2259     p->info   = 0;
2260     p->type   = 0;
2261     p->iosb.status = SS$_NORMAL;
2262 #if defined(PERL_IMPLICIT_CONTEXT)
2263     p->thx = aTHX;
2264 #endif
2265     pipe_infromchild_ast(p);
2266
2267     strcpy(wmbx, mbx1);
2268     strcpy(rmbx, mbx2);
2269     return p;
2270 }
2271
2272 static void
2273 pipe_infromchild_ast(pPipe p)
2274 {
2275     int iss = p->iosb.status;
2276     int eof = (iss == SS$_ENDOFFILE);
2277     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2278     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2279 #if defined(PERL_IMPLICIT_CONTEXT)
2280     pTHX = p->thx;
2281 #endif
2282
2283     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2284         _ckvmssts(sys$dassgn(p->chan_out));
2285         p->chan_out = 0;
2286     }
2287
2288     /* read completed:
2289             input shutdown if EOF from self (done or shut_on_empty)
2290             output shutdown if closing flag set (my_pclose)
2291             send data/eof from child or eof from self
2292             otherwise, re-read (snarf of data from child)
2293     */
2294
2295     if (p->type == 1) {
2296         p->type = 0;
2297         if (myeof && p->chan_in) {                  /* input shutdown */
2298             _ckvmssts(sys$dassgn(p->chan_in));
2299             p->chan_in = 0;
2300         }
2301
2302         if (p->chan_out) {
2303             if (myeof || kideof) {      /* pass EOF to parent */
2304                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2305                               pipe_infromchild_ast, p,
2306                               0, 0, 0, 0, 0, 0));
2307                 return;
2308             } else if (eof) {       /* eat EOF --- fall through to read*/
2309
2310             } else {                /* transmit data */
2311                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2312                               pipe_infromchild_ast,p,
2313                               p->buf, p->iosb.count, 0, 0, 0, 0));
2314                 return;
2315             }
2316         }
2317     }
2318
2319     /*  everything shut? flag as done */
2320
2321     if (!p->chan_in && !p->chan_out) {
2322         *p->pipe_done = TRUE;
2323         _ckvmssts(sys$setef(pipe_ef));
2324         return;
2325     }
2326
2327     /* write completed (or read, if snarfing from child)
2328             if still have input active,
2329                queue read...immediate mode if shut_on_empty so we get EOF if empty
2330             otherwise,
2331                check if Perl reading, generate EOFs as needed
2332     */
2333
2334     if (p->type == 0) {
2335         p->type = 1;
2336         if (p->chan_in) {
2337             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2338                           pipe_infromchild_ast,p,
2339                           p->buf, p->bufsize, 0, 0, 0, 0);
2340             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2341             _ckvmssts(iss);
2342         } else {           /* send EOFs for extra reads */
2343             p->iosb.status = SS$_ENDOFFILE;
2344             p->iosb.dvispec = 0;
2345             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2346                       0, 0, 0,
2347                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2348         }
2349     }
2350 }
2351
2352 static pPipe
2353 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2354 {
2355     pPipe p;
2356     char mbx[64];
2357     unsigned long dviitm = DVI$_DEVBUFSIZ;
2358     struct stat s;
2359     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2360                                       DSC$K_CLASS_S, mbx};
2361
2362     /* things like terminals and mbx's don't need this filter */
2363     if (fd && fstat(fd,&s) == 0) {
2364         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2365         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2366                                          DSC$K_CLASS_S, s.st_dev};
2367
2368         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2369         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2370             strcpy(out, s.st_dev);
2371             return 0;
2372         }
2373     }
2374
2375     Newx(p, 1, Pipe);
2376     p->fd_out = dup(fd);
2377     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2378     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2379     Newx(p->buf, p->bufsize+1, char);
2380     p->shut_on_empty = FALSE;
2381     p->retry = 0;
2382     p->info  = 0;
2383     strcpy(out, mbx);
2384
2385     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2386                   pipe_mbxtofd_ast, p,
2387                   p->buf, p->bufsize, 0, 0, 0, 0));
2388
2389     return p;
2390 }
2391
2392 static void
2393 pipe_mbxtofd_ast(pPipe p)
2394 {
2395     int iss = p->iosb.status;
2396     int done = p->info->done;
2397     int iss2;
2398     int eof = (iss == SS$_ENDOFFILE);
2399     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2400     int err = !(iss&1) && !eof;
2401 #if defined(PERL_IMPLICIT_CONTEXT)
2402     pTHX = p->thx;
2403 #endif
2404
2405     if (done && myeof) {               /* end piping */
2406         close(p->fd_out);
2407         sys$dassgn(p->chan_in);
2408         *p->pipe_done = TRUE;
2409         _ckvmssts(sys$setef(pipe_ef));
2410         return;
2411     }
2412
2413     if (!err && !eof) {             /* good data to send to file */
2414         p->buf[p->iosb.count] = '\n';
2415         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2416         if (iss2 < 0) {
2417             p->retry++;
2418             if (p->retry < MAX_RETRY) {
2419                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2420                 return;
2421             }
2422         }
2423         p->retry = 0;
2424     } else if (err) {
2425         _ckvmssts(iss);
2426     }
2427
2428
2429     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2430           pipe_mbxtofd_ast, p,
2431           p->buf, p->bufsize, 0, 0, 0, 0);
2432     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2433     _ckvmssts(iss);
2434 }
2435
2436
2437 typedef struct _pipeloc     PLOC;
2438 typedef struct _pipeloc*   pPLOC;
2439
2440 struct _pipeloc {
2441     pPLOC   next;
2442     char    dir[NAM$C_MAXRSS+1];
2443 };
2444 static pPLOC  head_PLOC = 0;
2445
2446 void
2447 free_pipelocs(pTHX_ void *head)
2448 {
2449     pPLOC p, pnext;
2450     pPLOC *pHead = (pPLOC *)head;
2451
2452     p = *pHead;
2453     while (p) {
2454         pnext = p->next;
2455         Safefree(p);
2456         p = pnext;
2457     }
2458     *pHead = 0;
2459 }
2460
2461 static void
2462 store_pipelocs(pTHX)
2463 {
2464     int    i;
2465     pPLOC  p;
2466     AV    *av = 0;
2467     SV    *dirsv;
2468     GV    *gv;
2469     char  *dir, *x;
2470     char  *unixdir;
2471     char  temp[NAM$C_MAXRSS+1];
2472     STRLEN n_a;
2473
2474     if (head_PLOC)
2475         free_pipelocs(aTHX_ &head_PLOC);
2476
2477 /*  the . directory from @INC comes last */
2478
2479     Newx(p,1,PLOC);
2480     p->next = head_PLOC;
2481     head_PLOC = p;
2482     strcpy(p->dir,"./");
2483
2484 /*  get the directory from $^X */
2485
2486 #ifdef PERL_IMPLICIT_CONTEXT
2487     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2488 #else
2489     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2490 #endif
2491         strcpy(temp, PL_origargv[0]);
2492         x = strrchr(temp,']');
2493         if (x) x[1] = '\0';
2494
2495         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2496             Newx(p,1,PLOC);
2497             p->next = head_PLOC;
2498             head_PLOC = p;
2499             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2500             p->dir[NAM$C_MAXRSS] = '\0';
2501         }
2502     }
2503
2504 /*  reverse order of @INC entries, skip "." since entered above */
2505
2506 #ifdef PERL_IMPLICIT_CONTEXT
2507     if (aTHX)
2508 #endif
2509     if (PL_incgv) av = GvAVn(PL_incgv);
2510
2511     for (i = 0; av && i <= AvFILL(av); i++) {
2512         dirsv = *av_fetch(av,i,TRUE);
2513
2514         if (SvROK(dirsv)) continue;
2515         dir = SvPVx(dirsv,n_a);
2516         if (strcmp(dir,".") == 0) continue;
2517         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2518             continue;
2519
2520         Newx(p,1,PLOC);
2521         p->next = head_PLOC;
2522         head_PLOC = p;
2523         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2524         p->dir[NAM$C_MAXRSS] = '\0';
2525     }
2526
2527 /* most likely spot (ARCHLIB) put first in the list */
2528
2529 #ifdef ARCHLIB_EXP
2530     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2531         Newx(p,1,PLOC);
2532         p->next = head_PLOC;
2533         head_PLOC = p;
2534         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2535         p->dir[NAM$C_MAXRSS] = '\0';
2536     }
2537 #endif
2538 }
2539
2540
2541 static char *
2542 find_vmspipe(pTHX)
2543 {
2544     static int   vmspipe_file_status = 0;
2545     static char  vmspipe_file[NAM$C_MAXRSS+1];
2546
2547     /* already found? Check and use ... need read+execute permission */
2548
2549     if (vmspipe_file_status == 1) {
2550         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2551          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2552             return vmspipe_file;
2553         }
2554         vmspipe_file_status = 0;
2555     }
2556
2557     /* scan through stored @INC, $^X */
2558
2559     if (vmspipe_file_status == 0) {
2560         char file[NAM$C_MAXRSS+1];
2561         pPLOC  p = head_PLOC;
2562
2563         while (p) {
2564             strcpy(file, p->dir);
2565             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2566             file[NAM$C_MAXRSS] = '\0';
2567             p = p->next;
2568
2569             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2570
2571             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2572              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2573                 vmspipe_file_status = 1;
2574                 return vmspipe_file;
2575             }
2576         }
2577         vmspipe_file_status = -1;   /* failed, use tempfiles */
2578     }
2579
2580     return 0;
2581 }
2582
2583 static FILE *
2584 vmspipe_tempfile(pTHX)
2585 {
2586     char file[NAM$C_MAXRSS+1];
2587     FILE *fp;
2588     static int index = 0;
2589     stat_t s0, s1;
2590
2591     /* create a tempfile */
2592
2593     /* we can't go from   W, shr=get to  R, shr=get without
2594        an intermediate vulnerable state, so don't bother trying...
2595
2596        and lib$spawn doesn't shr=put, so have to close the write
2597
2598        So... match up the creation date/time and the FID to
2599        make sure we're dealing with the same file
2600
2601     */
2602
2603     index++;
2604     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2605     fp = fopen(file,"w");
2606     if (!fp) {
2607         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2608         fp = fopen(file,"w");
2609         if (!fp) {
2610             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2611             fp = fopen(file,"w");
2612         }
2613     }
2614     if (!fp) return 0;  /* we're hosed */
2615
2616     fprintf(fp,"$! 'f$verify(0)'\n");
2617     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
2618     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
2619     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2620     fprintf(fp,"$ perl_on     = \"set noon\"\n");
2621     fprintf(fp,"$ perl_exit   = \"exit\"\n");
2622     fprintf(fp,"$ perl_del    = \"delete\"\n");
2623     fprintf(fp,"$ pif         = \"if\"\n");
2624     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
2625     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
2626     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
2627     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
2628     fprintf(fp,"$!  --- build command line to get max possible length\n");
2629     fprintf(fp,"$c=perl_popen_cmd0\n");
2630     fprintf(fp,"$c=c+perl_popen_cmd1\n");
2631     fprintf(fp,"$c=c+perl_popen_cmd2\n");
2632     fprintf(fp,"$x=perl_popen_cmd3\n");
2633     fprintf(fp,"$c=c+x\n");
2634     fprintf(fp,"$ perl_on\n");
2635     fprintf(fp,"$ 'c'\n");
2636     fprintf(fp,"$ perl_status = $STATUS\n");
2637     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2638     fprintf(fp,"$ perl_exit 'perl_status'\n");
2639     fsync(fileno(fp));
2640
2641     fgetname(fp, file, 1);
2642     fstat(fileno(fp), &s0);
2643     fclose(fp);
2644
2645     fp = fopen(file,"r","shr=get");
2646     if (!fp) return 0;
2647     fstat(fileno(fp), &s1);
2648
2649     if (s0.st_ino[0] != s1.st_ino[0] ||
2650         s0.st_ino[1] != s1.st_ino[1] ||
2651         s0.st_ino[2] != s1.st_ino[2] ||
2652         s0.st_ctime  != s1.st_ctime  )  {
2653         fclose(fp);
2654         return 0;
2655     }
2656
2657     return fp;
2658 }
2659
2660
2661
2662 static PerlIO *
2663 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
2664 {
2665     static int handler_set_up = FALSE;
2666     unsigned long int sts, flags = CLI$M_NOWAIT;
2667     /* The use of a GLOBAL table (as was done previously) rendered
2668      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2669      * environment.  Hence we've switched to LOCAL symbol table.
2670      */
2671     unsigned int table = LIB$K_CLI_LOCAL_SYM;
2672     int j, wait = 0;
2673     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2674     char in[512], out[512], err[512], mbx[512];
2675     FILE *tpipe = 0;
2676     char tfilebuf[NAM$C_MAXRSS+1];
2677     pInfo info;
2678     char cmd_sym_name[20];
2679     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2680                                       DSC$K_CLASS_S, symbol};
2681     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2682                                       DSC$K_CLASS_S, 0};
2683     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2684                                       DSC$K_CLASS_S, cmd_sym_name};
2685     struct dsc$descriptor_s *vmscmd;
2686     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2687     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2688     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2689
2690     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
2691
2692     /* once-per-program initialization...
2693        note that the SETAST calls and the dual test of pipe_ef
2694        makes sure that only the FIRST thread through here does
2695        the initialization...all other threads wait until it's
2696        done.
2697
2698        Yeah, uglier than a pthread call, it's got all the stuff inline
2699        rather than in a separate routine.
2700     */
2701
2702     if (!pipe_ef) {
2703         _ckvmssts(sys$setast(0));
2704         if (!pipe_ef) {
2705             unsigned long int pidcode = JPI$_PID;
2706             $DESCRIPTOR(d_delay, RETRY_DELAY);
2707             _ckvmssts(lib$get_ef(&pipe_ef));
2708             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2709             _ckvmssts(sys$bintim(&d_delay, delaytime));
2710         }
2711         if (!handler_set_up) {
2712           _ckvmssts(sys$dclexh(&pipe_exitblock));
2713           handler_set_up = TRUE;
2714         }
2715         _ckvmssts(sys$setast(1));
2716     }
2717
2718     /* see if we can find a VMSPIPE.COM */
2719
2720     tfilebuf[0] = '@';
2721     vmspipe = find_vmspipe(aTHX);
2722     if (vmspipe) {
2723         strcpy(tfilebuf+1,vmspipe);
2724     } else {        /* uh, oh...we're in tempfile hell */
2725         tpipe = vmspipe_tempfile(aTHX);
2726         if (!tpipe) {       /* a fish popular in Boston */
2727             if (ckWARN(WARN_PIPE)) {
2728                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2729             }
2730         return Nullfp;
2731         }
2732         fgetname(tpipe,tfilebuf+1,1);
2733     }
2734     vmspipedsc.dsc$a_pointer = tfilebuf;
2735     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2736
2737     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2738     if (!(sts & 1)) {
2739       switch (sts) {
2740         case RMS$_FNF:  case RMS$_DNF:
2741           set_errno(ENOENT); break;
2742         case RMS$_DIR:
2743           set_errno(ENOTDIR); break;
2744         case RMS$_DEV:
2745           set_errno(ENODEV); break;
2746         case RMS$_PRV:
2747           set_errno(EACCES); break;
2748         case RMS$_SYN:
2749           set_errno(EINVAL); break;
2750         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2751           set_errno(E2BIG); break;
2752         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2753           _ckvmssts(sts); /* fall through */
2754         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2755           set_errno(EVMSERR);
2756       }
2757       set_vaxc_errno(sts);
2758       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2759         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2760       }
2761       *psts = sts;
2762       return Nullfp;
2763     }
2764     Newx(info,1,Info);
2765
2766     strcpy(mode,in_mode);
2767     info->mode = *mode;
2768     info->done = FALSE;
2769     info->completion = 0;
2770     info->closing    = FALSE;
2771     info->in         = 0;
2772     info->out        = 0;
2773     info->err        = 0;
2774     info->fp         = Nullfp;
2775     info->useFILE    = 0;
2776     info->waiting    = 0;
2777     info->in_done    = TRUE;
2778     info->out_done   = TRUE;
2779     info->err_done   = TRUE;
2780     in[0] = out[0] = err[0] = '\0';
2781
2782     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2783         info->useFILE = 1;
2784         strcpy(p,p+1);
2785     }
2786     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2787         wait = 1;
2788         strcpy(p,p+1);
2789     }
2790
2791     if (*mode == 'r') {             /* piping from subroutine */
2792
2793         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2794         if (info->out) {
2795             info->out->pipe_done = &info->out_done;
2796             info->out_done = FALSE;
2797             info->out->info = info;
2798         }
2799         if (!info->useFILE) {
2800         info->fp  = PerlIO_open(mbx, mode);
2801         } else {
2802             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2803             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2804         }
2805
2806         if (!info->fp && info->out) {
2807             sys$cancel(info->out->chan_out);
2808
2809             while (!info->out_done) {
2810                 int done;
2811                 _ckvmssts(sys$setast(0));
2812                 done = info->out_done;
2813                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2814                 _ckvmssts(sys$setast(1));
2815                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2816             }
2817
2818             if (info->out->buf) Safefree(info->out->buf);
2819             Safefree(info->out);
2820             Safefree(info);
2821             *psts = RMS$_FNF;
2822             return Nullfp;
2823         }
2824
2825         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2826         if (info->err) {
2827             info->err->pipe_done = &info->err_done;
2828             info->err_done = FALSE;
2829             info->err->info = info;
2830         }
2831
2832     } else if (*mode == 'w') {      /* piping to subroutine */
2833
2834         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2835         if (info->out) {
2836             info->out->pipe_done = &info->out_done;
2837             info->out_done = FALSE;
2838             info->out->info = info;
2839         }
2840
2841         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2842         if (info->err) {
2843             info->err->pipe_done = &info->err_done;
2844             info->err_done = FALSE;
2845             info->err->info = info;
2846         }
2847
2848         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2849         if (!info->useFILE) {
2850         info->fp  = PerlIO_open(mbx, mode);
2851         } else {
2852             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2853             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2854         }
2855
2856         if (info->in) {
2857             info->in->pipe_done = &info->in_done;
2858             info->in_done = FALSE;
2859             info->in->info = info;
2860         }
2861
2862         /* error cleanup */
2863         if (!info->fp && info->in) {
2864             info->done = TRUE;
2865             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2866                               0, 0, 0, 0, 0, 0, 0, 0));
2867
2868             while (!info->in_done) {
2869                 int done;
2870                 _ckvmssts(sys$setast(0));
2871                 done = info->in_done;
2872                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2873                 _ckvmssts(sys$setast(1));
2874                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2875             }
2876
2877             if (info->in->buf) Safefree(info->in->buf);
2878             Safefree(info->in);
2879             Safefree(info);
2880             *psts = RMS$_FNF;
2881             return Nullfp;
2882         }
2883
2884
2885     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2886         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2887         if (info->out) {
2888             info->out->pipe_done = &info->out_done;
2889             info->out_done = FALSE;
2890             info->out->info = info;
2891         }
2892
2893         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2894         if (info->err) {
2895             info->err->pipe_done = &info->err_done;
2896             info->err_done = FALSE;
2897             info->err->info = info;
2898         }
2899     }
2900
2901     symbol[MAX_DCL_SYMBOL] = '\0';
2902
2903     strncpy(symbol, in, MAX_DCL_SYMBOL);
2904     d_symbol.dsc$w_length = strlen(symbol);
2905     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2906
2907     strncpy(symbol, err, MAX_DCL_SYMBOL);
2908     d_symbol.dsc$w_length = strlen(symbol);
2909     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2910
2911     strncpy(symbol, out, MAX_DCL_SYMBOL);
2912     d_symbol.dsc$w_length = strlen(symbol);
2913     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2914
2915     p = vmscmd->dsc$a_pointer;
2916     while (*p && *p != '\n') p++;
2917     *p = '\0';                                  /* truncate on \n */
2918     p = vmscmd->dsc$a_pointer;
2919     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2920     if (*p == '$') p++;                         /* remove leading $ */
2921     while (*p == ' ' || *p == '\t') p++;
2922
2923     for (j = 0; j < 4; j++) {
2924         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2925         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2926
2927     strncpy(symbol, p, MAX_DCL_SYMBOL);
2928     d_symbol.dsc$w_length = strlen(symbol);
2929     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2930
2931         if (strlen(p) > MAX_DCL_SYMBOL) {
2932             p += MAX_DCL_SYMBOL;
2933         } else {
2934             p += strlen(p);
2935         }
2936     }
2937     _ckvmssts(sys$setast(0));
2938     info->next=open_pipes;  /* prepend to list */
2939     open_pipes=info;
2940     _ckvmssts(sys$setast(1));
2941     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2942      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
2943      * have SYS$COMMAND if we need it.
2944      */
2945     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2946                       0, &info->pid, &info->completion,
2947                       0, popen_completion_ast,info,0,0,0));
2948
2949     /* if we were using a tempfile, close it now */
2950
2951     if (tpipe) fclose(tpipe);
2952
2953     /* once the subprocess is spawned, it has copied the symbols and
2954        we can get rid of ours */
2955
2956     for (j = 0; j < 4; j++) {
2957         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2958         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2959     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2960     }
2961     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2962     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2963     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2964     vms_execfree(vmscmd);
2965
2966 #ifdef PERL_IMPLICIT_CONTEXT
2967     if (aTHX)
2968 #endif
2969     PL_forkprocess = info->pid;
2970
2971     if (wait) {
2972          int done = 0;
2973          while (!done) {
2974              _ckvmssts(sys$setast(0));
2975              done = info->done;
2976              if (!done) _ckvmssts(sys$clref(pipe_ef));
2977              _ckvmssts(sys$setast(1));
2978              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2979          }
2980         *psts = info->completion;
2981 /* Caller thinks it is open and tries to close it. */
2982 /* This causes some problems, as it changes the error status */
2983 /*        my_pclose(info->fp); */
2984     } else {
2985         *psts = SS$_NORMAL;
2986     }
2987     return info->fp;
2988 }  /* end of safe_popen */
2989
2990
2991 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2992 PerlIO *
2993 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2994 {
2995     int sts;
2996     TAINT_ENV();
2997     TAINT_PROPER("popen");
2998     PERL_FLUSHALL_FOR_CHILD;
2999     return safe_popen(aTHX_ cmd,mode,&sts);
3000 }
3001
3002 /*}}}*/
3003
3004 /*{{{  I32 my_pclose(PerlIO *fp)*/
3005 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3006 {
3007     pInfo info, last = NULL;
3008     unsigned long int retsts;
3009     int done, iss;
3010
3011     for (info = open_pipes; info != NULL; last = info, info = info->next)
3012         if (info->fp == fp) break;
3013
3014     if (info == NULL) {  /* no such pipe open */
3015       set_errno(ECHILD); /* quoth POSIX */
3016       set_vaxc_errno(SS$_NONEXPR);
3017       return -1;
3018     }
3019
3020     /* If we were writing to a subprocess, insure that someone reading from
3021      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3022      * produce an EOF record in the mailbox.
3023      *
3024      *  well, at least sometimes it *does*, so we have to watch out for
3025      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3026      */
3027      if (info->fp) {
3028         if (!info->useFILE)
3029      PerlIO_flush(info->fp);   /* first, flush data */
3030         else
3031             fflush((FILE *)info->fp);
3032     }
3033
3034     _ckvmssts(sys$setast(0));
3035      info->closing = TRUE;
3036      done = info->done && info->in_done && info->out_done && info->err_done;
3037      /* hanging on write to Perl's input? cancel it */
3038      if (info->mode == 'r' && info->out && !info->out_done) {
3039         if (info->out->chan_out) {
3040             _ckvmssts(sys$cancel(info->out->chan_out));
3041             if (!info->out->chan_in) {   /* EOF generation, need AST */
3042                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3043             }
3044         }
3045      }
3046      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3047          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3048                            0, 0, 0, 0, 0, 0));
3049     _ckvmssts(sys$setast(1));
3050     if (info->fp) {
3051      if (!info->useFILE)
3052     PerlIO_close(info->fp);
3053      else
3054         fclose((FILE *)info->fp);
3055     }
3056      /*
3057         we have to wait until subprocess completes, but ALSO wait until all
3058         the i/o completes...otherwise we'll be freeing the "info" structure
3059         that the i/o ASTs could still be using...
3060      */
3061
3062      while (!done) {
3063          _ckvmssts(sys$setast(0));
3064          done = info->done && info->in_done && info->out_done && info->err_done;
3065          if (!done) _ckvmssts(sys$clref(pipe_ef));
3066          _ckvmssts(sys$setast(1));
3067          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3068      }
3069      retsts = info->completion;
3070
3071     /* remove from list of open pipes */
3072     _ckvmssts(sys$setast(0));
3073     if (last) last->next = info->next;
3074     else open_pipes = info->next;
3075     _ckvmssts(sys$setast(1));
3076
3077     /* free buffers and structures */
3078
3079     if (info->in) {
3080         if (info->in->buf) Safefree(info->in->buf);
3081         Safefree(info->in);
3082     }
3083     if (info->out) {
3084         if (info->out->buf) Safefree(info->out->buf);
3085         Safefree(info->out);
3086     }
3087     if (info->err) {
3088         if (info->err->buf) Safefree(info->err->buf);
3089         Safefree(info->err);
3090     }
3091     Safefree(info);
3092
3093     return retsts;
3094
3095 }  /* end of my_pclose() */
3096
3097 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3098   /* Roll our own prototype because we want this regardless of whether
3099    * _VMS_WAIT is defined.
3100    */
3101   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3102 #endif
3103 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3104    created with popen(); otherwise partially emulate waitpid() unless
3105    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3106    Also check processes not considered by the CRTL waitpid().
3107  */
3108 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3109 Pid_t
3110 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3111 {
3112     pInfo info;
3113     int done;
3114     int sts;
3115     int j;
3116
3117     if (statusp) *statusp = 0;
3118
3119     for (info = open_pipes; info != NULL; info = info->next)
3120         if (info->pid == pid) break;
3121
3122     if (info != NULL) {  /* we know about this child */
3123       while (!info->done) {
3124           _ckvmssts(sys$setast(0));
3125           done = info->done;
3126           if (!done) _ckvmssts(sys$clref(pipe_ef));
3127           _ckvmssts(sys$setast(1));
3128           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3129       }
3130
3131       if (statusp) *statusp = info->completion;
3132       return pid;
3133     }
3134
3135     /* child that already terminated? */
3136
3137     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3138         if (closed_list[j].pid == pid) {
3139             if (statusp) *statusp = closed_list[j].completion;
3140             return pid;
3141         }
3142     }
3143
3144     /* fall through if this child is not one of our own pipe children */
3145
3146 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3147
3148       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3149        * in 7.2 did we get a version that fills in the VMS completion
3150        * status as Perl has always tried to do.
3151        */
3152
3153       sts = __vms_waitpid( pid, statusp, flags );
3154
3155       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3156          return sts;
3157
3158       /* If the real waitpid tells us the child does not exist, we
3159        * fall through here to implement waiting for a child that
3160        * was created by some means other than exec() (say, spawned
3161        * from DCL) or to wait for a process that is not a subprocess
3162        * of the current process.
3163        */
3164
3165 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3166
3167     {
3168       $DESCRIPTOR(intdsc,"0 00:00:01");
3169       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3170       unsigned long int pidcode = JPI$_PID, mypid;
3171       unsigned long int interval[2];
3172       unsigned int jpi_iosb[2];
3173       struct itmlst_3 jpilist[2] = {
3174           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3175           {                      0,         0,                 0, 0}
3176       };
3177
3178       if (pid <= 0) {
3179         /* Sorry folks, we don't presently implement rooting around for
3180            the first child we can find, and we definitely don't want to
3181            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3182          */
3183         set_errno(ENOTSUP);
3184         return -1;
3185       }
3186
3187       /* Get the owner of the child so I can warn if it's not mine. If the
3188        * process doesn't exist or I don't have the privs to look at it,
3189        * I can go home early.
3190        */
3191       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3192       if (sts & 1) sts = jpi_iosb[0];
3193       if (!(sts & 1)) {
3194         switch (sts) {
3195             case SS$_NONEXPR:
3196                 set_errno(ECHILD);
3197                 break;
3198             case SS$_NOPRIV:
3199                 set_errno(EACCES);
3200                 break;
3201             default:
3202                 _ckvmssts(sts);
3203         }
3204         set_vaxc_errno(sts);
3205         return -1;
3206       }
3207
3208       if (ckWARN(WARN_EXEC)) {
3209         /* remind folks they are asking for non-standard waitpid behavior */
3210         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3211         if (ownerpid != mypid)
3212           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3213                       "waitpid: process %x is not a child of process %x",
3214                       pid,mypid);
3215       }
3216
3217       /* simply check on it once a second until it's not there anymore. */
3218
3219       _ckvmssts(sys$bintim(&intdsc,interval));
3220       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3221             _ckvmssts(sys$schdwk(0,0,interval,0));
3222             _ckvmssts(sys$hiber());
3223       }
3224       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3225
3226       _ckvmssts(sts);
3227       return pid;
3228     }
3229 }  /* end of waitpid() */
3230 /*}}}*/
3231 /*}}}*/
3232 /*}}}*/
3233
3234 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3235 char *
3236 my_gconvert(double val, int ndig, int trail, char *buf)
3237 {
3238   static char __gcvtbuf[DBL_DIG+1];
3239   char *loc;
3240
3241   loc = buf ? buf : __gcvtbuf;
3242
3243 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3244   if (val < 1) {
3245     sprintf(loc,"%.*g",ndig,val);
3246     return loc;
3247   }
3248 #endif
3249
3250   if (val) {
3251     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3252     return gcvt(val,ndig,loc);
3253   }
3254   else {
3255     loc[0] = '0'; loc[1] = '\0';
3256     return loc;
3257   }
3258
3259 }
3260 /*}}}*/
3261
3262
3263 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3264 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3265  * to expand file specification.  Allows for a single default file
3266  * specification and a simple mask of options.  If outbuf is non-NULL,
3267  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3268  * the resultant file specification is placed.  If outbuf is NULL, the
3269  * resultant file specification is placed into a static buffer.
3270  * The third argument, if non-NULL, is taken to be a default file
3271  * specification string.  The fourth argument is unused at present.
3272  * rmesexpand() returns the address of the resultant string if
3273  * successful, and NULL on error.
3274  */
3275 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3276
3277 static char *
3278 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3279 {
3280   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3281   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3282   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3283   struct FAB myfab = cc$rms_fab;
3284   struct NAM mynam = cc$rms_nam;
3285   STRLEN speclen;
3286   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3287   int sts;
3288
3289   if (!filespec || !*filespec) {
3290     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3291     return NULL;
3292   }
3293   if (!outbuf) {
3294     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3295     else    outbuf = __rmsexpand_retbuf;
3296   }
3297   if ((isunix = (strchr(filespec,'/') != NULL))) {
3298     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3299     filespec = vmsfspec;
3300   }
3301
3302   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3303   myfab.fab$b_fns = strlen(filespec);
3304   myfab.fab$l_nam = &mynam;
3305
3306   if (defspec && *defspec) {
3307     if (strchr(defspec,'/') != NULL) {
3308       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3309       defspec = tmpfspec;
3310     }
3311     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3312     myfab.fab$b_dns = strlen(defspec);
3313   }
3314
3315   mynam.nam$l_esa = esa;
3316   mynam.nam$b_ess = sizeof esa;
3317   mynam.nam$l_rsa = outbuf;
3318   mynam.nam$b_rss = NAM$C_MAXRSS;
3319
3320   retsts = sys$parse(&myfab,0,0);
3321   if (!(retsts & 1)) {
3322     mynam.nam$b_nop |= NAM$M_SYNCHK;
3323 #ifdef NAM$M_NO_SHORT_UPCASE
3324     if (decc_efs_case_preserve)
3325       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3326 #endif
3327     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3328       retsts = sys$parse(&myfab,0,0);
3329       if (retsts & 1) goto expanded;
3330     }
3331     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3332     sts = sys$parse(&myfab,0,0);  /* Free search context */
3333     if (out) Safefree(out);
3334     set_vaxc_errno(retsts);
3335     if      (retsts == RMS$_PRV) set_errno(EACCES);
3336     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3337     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3338     else                         set_errno(EVMSERR);
3339     return NULL;
3340   }
3341   retsts = sys$search(&myfab,0,0);
3342   if (!(retsts & 1) && retsts != RMS$_FNF) {
3343     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3344 #ifdef NAM$M_NO_SHORT_UPCASE
3345     if (decc_efs_case_preserve)
3346       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3347 #endif
3348     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3349     if (out) Safefree(out);
3350     set_vaxc_errno(retsts);
3351     if      (retsts == RMS$_PRV) set_errno(EACCES);
3352     else                         set_errno(EVMSERR);
3353     return NULL;
3354   }
3355
3356   /* If the input filespec contained any lowercase characters,
3357    * downcase the result for compatibility with Unix-minded code. */
3358   expanded:
3359   if (!decc_efs_case_preserve) {
3360     for (out = myfab.fab$l_fna; *out; out++)
3361       if (islower(*out)) { haslower = 1; break; }
3362   }
3363   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3364   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3365   /* Trim off null fields added by $PARSE
3366    * If type > 1 char, must have been specified in original or default spec
3367    * (not true for version; $SEARCH may have added version of existing file).
3368    */
3369   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3370   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3371              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3372   if (trimver || trimtype) {
3373     if (defspec && *defspec) {
3374       char defesa[NAM$C_MAXRSS];
3375       struct FAB deffab = cc$rms_fab;
3376       struct NAM defnam = cc$rms_nam;
3377
3378       deffab.fab$l_nam = &defnam;
3379       /* cast below ok for read only pointer */
3380       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3381       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3382       defnam.nam$b_nop = NAM$M_SYNCHK;
3383 #ifdef NAM$M_NO_SHORT_UPCASE
3384       if (decc_efs_case_preserve)
3385         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3386 #endif
3387       if (sys$parse(&deffab,0,0) & 1) {
3388         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3389         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3390       }
3391     }
3392     if (trimver) speclen = mynam.nam$l_ver - out;
3393     if (trimtype) {
3394       /* If we didn't already trim version, copy down */
3395       if (speclen > mynam.nam$l_ver - out)
3396         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3397                speclen - (mynam.nam$l_ver - out));
3398       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3399     }
3400   }
3401   /* If we just had a directory spec on input, $PARSE "helpfully"
3402    * adds an empty name and type for us */
3403   if (mynam.nam$l_name == mynam.nam$l_type &&
3404       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
3405       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3406     speclen = mynam.nam$l_name - out;
3407   out[speclen] = '\0';
3408   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3409
3410   /* Have we been working with an expanded, but not resultant, spec? */
3411   /* Also, convert back to Unix syntax if necessary. */
3412   if (!mynam.nam$b_rsl) {
3413     if (isunix) {
3414       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3415     }
3416     else strcpy(outbuf,esa);
3417   }
3418   else if (isunix) {
3419     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3420     strcpy(outbuf,tmpfspec);
3421   }
3422   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3423 #ifdef NAM$M_NO_SHORT_UPCASE
3424   if (decc_efs_case_preserve)
3425     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3426 #endif
3427   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3428   myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3429   return outbuf;
3430 }
3431 /*}}}*/
3432 /* External entry points */
3433 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3434 { return do_rmsexpand(spec,buf,0,def,opt); }
3435 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3436 { return do_rmsexpand(spec,buf,1,def,opt); }
3437
3438
3439 /*
3440 ** The following routines are provided to make life easier when
3441 ** converting among VMS-style and Unix-style directory specifications.
3442 ** All will take input specifications in either VMS or Unix syntax. On
3443 ** failure, all return NULL.  If successful, the routines listed below
3444 ** return a pointer to a buffer containing the appropriately
3445 ** reformatted spec (and, therefore, subsequent calls to that routine
3446 ** will clobber the result), while the routines of the same names with
3447 ** a _ts suffix appended will return a pointer to a mallocd string
3448 ** containing the appropriately reformatted spec.
3449 ** In all cases, only explicit syntax is altered; no check is made that
3450 ** the resulting string is valid or that the directory in question
3451 ** actually exists.
3452 **
3453 **   fileify_dirspec() - convert a directory spec into the name of the
3454 **     directory file (i.e. what you can stat() to see if it's a dir).
3455 **     The style (VMS or Unix) of the result is the same as the style
3456 **     of the parameter passed in.
3457 **   pathify_dirspec() - convert a directory spec into a path (i.e.
3458 **     what you prepend to a filename to indicate what directory it's in).
3459 **     The style (VMS or Unix) of the result is the same as the style
3460 **     of the parameter passed in.
3461 **   tounixpath() - convert a directory spec into a Unix-style path.
3462 **   tovmspath() - convert a directory spec into a VMS-style path.
3463 **   tounixspec() - convert any file spec into a Unix-style file spec.
3464 **   tovmsspec() - convert any file spec into a VMS-style spec.
3465 **
3466 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
3467 ** Permission is given to distribute this code as part of the Perl
3468 ** standard distribution under the terms of the GNU General Public
3469 ** License or the Perl Artistic License.  Copies of each may be
3470 ** found in the Perl standard distribution.
3471  */
3472
3473 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3474 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
3475 {
3476     static char __fileify_retbuf[NAM$C_MAXRSS+1];
3477     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3478     char *retspec, *cp1, *cp2, *lastdir;
3479     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3480     unsigned short int trnlnm_iter_count;
3481     int sts;
3482
3483     if (!dir || !*dir) {
3484       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3485     }
3486     dirlen = strlen(dir);
3487     while (dirlen && dir[dirlen-1] == '/') --dirlen;
3488     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3489       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
3490         dir = "/sys$disk";
3491         dirlen = 9;
3492       }
3493       else
3494         dirlen = 1;
3495     }
3496     if (dirlen > NAM$C_MAXRSS) {
3497       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3498     }
3499     if (!strpbrk(dir+1,"/]>:")  &&
3500         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
3501       strcpy(trndir,*dir == '/' ? dir + 1: dir);
3502       trnlnm_iter_count = 0;
3503       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3504         trnlnm_iter_count++;
3505         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3506       }
3507       dirlen = strlen(trndir);
3508     }
3509     else {
3510       strncpy(trndir,dir,dirlen);
3511       trndir[dirlen] = '\0';
3512     }
3513
3514     /* At this point we are done with *dir and use *trndir which is a
3515      * copy that can be modified.  *dir must not be modified.
3516      */
3517
3518     /* If we were handed a rooted logical name or spec, treat it like a
3519      * simple directory, so that
3520      *    $ Define myroot dev:[dir.]
3521      *    ... do_fileify_dirspec("myroot",buf,1) ...
3522      * does something useful.
3523      */
3524     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
3525       trndir[--dirlen] = '\0';
3526       trndir[dirlen-1] = ']';
3527     }
3528     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
3529       trndir[--dirlen] = '\0';
3530       trndir[dirlen-1] = '>';
3531     }
3532
3533     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
3534       /* If we've got an explicit filename, we can just shuffle the string. */
3535       if (*(cp1+1)) hasfilename = 1;
3536       /* Similarly, we can just back up a level if we've got multiple levels
3537          of explicit directories in a VMS spec which ends with directories. */
3538       else {
3539         for (cp2 = cp1; cp2 > trndir; cp2--) {
3540           if (*cp2 == '.') {
3541             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
3542               *cp2 = *cp1; *cp1 = '\0';
3543               hasfilename = 1;
3544               break;
3545             }
3546           }
3547           if (*cp2 == '[' || *cp2 == '<') break;
3548         }
3549       }
3550     }
3551
3552     cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
3553     if (hasfilename || !cp1) { /* Unix-style path or filename */
3554       if (trndir[0] == '.') {
3555         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
3556           return do_fileify_dirspec("[]",buf,ts);
3557         else if (trndir[1] == '.' &&
3558                  (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
3559           return do_fileify_dirspec("[-]",buf,ts);
3560       }
3561       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
3562         dirlen -= 1;                 /* to last element */
3563         lastdir = strrchr(trndir,'/');
3564       }
3565       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
3566         /* If we have "/." or "/..", VMSify it and let the VMS code
3567          * below expand it, rather than repeating the code to handle
3568          * relative components of a filespec here */
3569         do {
3570           if (*(cp1+2) == '.') cp1++;
3571           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3572             if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3573             if (strchr(vmsdir,'/') != NULL) {
3574               /* If do_tovmsspec() returned it, it must have VMS syntax
3575                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
3576                * the time to check this here only so we avoid a recursion
3577                * loop; otherwise, gigo.
3578                */
3579               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
3580             }
3581             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3582             return do_tounixspec(trndir,buf,ts);
3583           }
3584           cp1++;
3585         } while ((cp1 = strstr(cp1,"/.")) != NULL);
3586         lastdir = strrchr(trndir,'/');
3587       }
3588       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
3589         /* Ditto for specs that end in an MFD -- let the VMS code
3590          * figure out whether it's a real device or a rooted logical. */
3591
3592         /* This should not happen any more.  Allowing the fake /000000
3593          * in a UNIX pathname causes all sorts of problems when trying
3594          * to run in UNIX emulation.  So the VMS to UNIX conversions
3595          * now remove the fake /000000 directories.
3596          */
3597
3598         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
3599         if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3600         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3601         return do_tounixspec(trndir,buf,ts);
3602       }
3603       else {
3604
3605         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
3606              !(lastdir = cp1 = strrchr(trndir,']')) &&
3607              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
3608         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
3609           int ver; char *cp3;
3610
3611           /* For EFS or ODS-5 look for the last dot */
3612           if (decc_efs_charset) {
3613               cp2 = strrchr(cp1,'.');
3614           }
3615           if (vms_process_case_tolerant) {
3616               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3617                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3618                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3619                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3620                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3621                             (ver || *cp3)))))) {
3622                   set_errno(ENOTDIR);
3623                   set_vaxc_errno(RMS$_DIR);
3624                   return NULL;
3625               }
3626           }
3627           else {
3628               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
3629                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
3630                   !*(cp2+3) || *(cp2+3) != 'R' ||
3631                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3632                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3633                             (ver || *cp3)))))) {
3634                  set_errno(ENOTDIR);
3635                  set_vaxc_errno(RMS$_DIR);
3636                  return NULL;
3637               }
3638           }
3639           dirlen = cp2 - trndir;
3640         }
3641       }
3642
3643       retlen = dirlen + 6;
3644       if (buf) retspec = buf;
3645       else if (ts) Newx(retspec,retlen+1,char);
3646       else retspec = __fileify_retbuf;
3647       memcpy(retspec,trndir,dirlen);
3648       retspec[dirlen] = '\0';
3649
3650       /* We've picked up everything up to the directory file name.
3651          Now just add the type and version, and we're set. */
3652       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
3653         strcat(retspec,".dir;1");
3654       else
3655         strcat(retspec,".DIR;1");
3656       return retspec;
3657     }
3658     else {  /* VMS-style directory spec */
3659       char esa[NAM$C_MAXRSS+1], term, *cp;
3660       unsigned long int sts, cmplen, haslower = 0;
3661       struct FAB dirfab = cc$rms_fab;
3662       struct NAM savnam, dirnam = cc$rms_nam;
3663
3664       dirfab.fab$b_fns = strlen(trndir);
3665       dirfab.fab$l_fna = trndir;
3666       dirfab.fab$l_nam = &dirnam;
3667       dirfab.fab$l_dna = ".DIR;1";
3668       dirfab.fab$b_dns = 6;
3669       dirnam.nam$b_ess = NAM$C_MAXRSS;
3670       dirnam.nam$l_esa = esa;
3671 #ifdef NAM$M_NO_SHORT_UPCASE
3672       if (decc_efs_case_preserve)
3673         dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3674 #endif
3675
3676       for (cp = trndir; *cp; cp++)
3677         if (islower(*cp)) { haslower = 1; break; }
3678       if (!((sts = sys$parse(&dirfab))&1)) {
3679         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
3680           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3681           sts = sys$parse(&dirfab) & 1;
3682         }
3683         if (!sts) {
3684           set_errno(EVMSERR);
3685           set_vaxc_errno(dirfab.fab$l_sts);
3686           return NULL;
3687         }
3688       }
3689       else {
3690         savnam = dirnam;
3691         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3692           /* Yes; fake the fnb bits so we'll check type below */
3693           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3694         }
3695         else { /* No; just work with potential name */
3696           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3697           else {
3698             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3699             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3700             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3701             return NULL;
3702           }
3703         }
3704       }
3705       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3706         cp1 = strchr(esa,']');
3707         if (!cp1) cp1 = strchr(esa,'>');
3708         if (cp1) {  /* Should always be true */
3709           dirnam.nam$b_esl -= cp1 - esa - 1;
3710           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3711         }
3712       }
3713       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3714         /* Yep; check version while we're at it, if it's there. */
3715         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3716         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3717           /* Something other than .DIR[;1].  Bzzt. */
3718           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3719           dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3720           set_errno(ENOTDIR);
3721           set_vaxc_errno(RMS$_DIR);
3722           return NULL;
3723         }
3724       }
3725       esa[dirnam.nam$b_esl] = '\0';
3726       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3727         /* They provided at least the name; we added the type, if necessary, */
3728         if (buf) retspec = buf;                            /* in sys$parse() */
3729         else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
3730         else retspec = __fileify_retbuf;
3731         strcpy(retspec,esa);
3732         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3733         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3734         return retspec;
3735       }
3736       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3737         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3738         *cp1 = '\0';
3739         dirnam.nam$b_esl -= 9;
3740       }
3741       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3742       if (cp1 == NULL) { /* should never happen */
3743         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3744         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3745         return NULL;
3746       }
3747       term = *cp1;
3748       *cp1 = '\0';
3749       retlen = strlen(esa);
3750       cp1 = strrchr(esa,'.');
3751       /* ODS-5 directory specifications can have extra "." in them. */
3752       while (cp1 != NULL) {
3753         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
3754           break;
3755         else {
3756            cp1--;
3757            while ((cp1 > esa) && (*cp1 != '.'))
3758              cp1--;
3759         }
3760         if (cp1 == esa)
3761           cp1 = NULL;
3762       }
3763
3764       if ((cp1) != NULL) {
3765         /* There's more than one directory in the path.  Just roll back. */
3766         *cp1 = term;
3767         if (buf) retspec = buf;
3768         else if (ts) Newx(retspec,retlen+7,char);
3769         else retspec = __fileify_retbuf;
3770         strcpy(retspec,esa);
3771       }
3772       else {
3773         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3774           /* Go back and expand rooted logical name */
3775           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3776 #ifdef NAM$M_NO_SHORT_UPCASE
3777           if (decc_efs_case_preserve)
3778             dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3779 #endif
3780           if (!(sys$parse(&dirfab) & 1)) {
3781             dirnam.nam$l_rlf = NULL;
3782             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3783             set_errno(EVMSERR);
3784             set_vaxc_errno(dirfab.fab$l_sts);
3785             return NULL;
3786           }
3787           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3788           if (buf) retspec = buf;
3789           else if (ts) Newx(retspec,retlen+16,char);
3790           else retspec = __fileify_retbuf;
3791           cp1 = strstr(esa,"][");
3792           if (!cp1) cp1 = strstr(esa,"]<");
3793           dirlen = cp1 - esa;
3794           memcpy(retspec,esa,dirlen);
3795           if (!strncmp(cp1+2,"000000]",7)) {
3796             retspec[dirlen-1] = '\0';
3797             /* Not full ODS-5, just extra dots in directories for now */
3798             cp1 = retspec + dirlen - 1;
3799             while (cp1 > retspec)
3800             {
3801               if (*cp1 == '[')
3802                 break;
3803               if (*cp1 == '.') {
3804                 if (*(cp1-1) != '^')
3805                   break;
3806               }
3807               cp1--;
3808             }
3809             if (*cp1 == '.') *cp1 = ']';
3810             else {
3811               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3812               memcpy(cp1+1,"000000]",7);
3813             }
3814           }
3815           else {
3816             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3817             retspec[retlen] = '\0';
3818             /* Convert last '.' to ']' */
3819             cp1 = retspec+retlen-1;
3820             while (*cp != '[') {
3821               cp1--;
3822               if (*cp1 == '.') {
3823                 /* Do not trip on extra dots in ODS-5 directories */
3824                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
3825                 break;
3826               }
3827             }
3828             if (*cp1 == '.') *cp1 = ']';
3829             else {
3830               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3831               memcpy(cp1+1,"000000]",7);
3832             }
3833           }
3834         }
3835         else {  /* This is a top-level dir.  Add the MFD to the path. */
3836           if (buf) retspec = buf;
3837           else if (ts) Newx(retspec,retlen+16,char);
3838           else retspec = __fileify_retbuf;
3839           cp1 = esa;
3840           cp2 = retspec;
3841           while (*cp1 != ':') *(cp2++) = *(cp1++);
3842           strcpy(cp2,":[000000]");
3843           cp1 += 2;
3844           strcpy(cp2+9,cp1);
3845         }
3846       }
3847       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3848       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
3849       /* We've set up the string up through the filename.  Add the
3850          type and version, and we're done. */
3851       strcat(retspec,".DIR;1");
3852
3853       /* $PARSE may have upcased filespec, so convert output to lower
3854        * case if input contained any lowercase characters. */
3855       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
3856       return retspec;
3857     }
3858 }  /* end of do_fileify_dirspec() */
3859 /*}}}*/
3860 /* External entry points */
3861 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
3862 { return do_fileify_dirspec(dir,buf,0); }
3863 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
3864 { return do_fileify_dirspec(dir,buf,1); }
3865
3866 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3867 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
3868 {
3869     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3870     unsigned long int retlen;
3871     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3872     unsigned short int trnlnm_iter_count;
3873     STRLEN trnlen;
3874     int sts;
3875
3876     if (!dir || !*dir) {
3877       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3878     }
3879
3880     if (*dir) strcpy(trndir,dir);
3881     else getcwd(trndir,sizeof trndir - 1);
3882
3883     trnlnm_iter_count = 0;
3884     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3885            && my_trnlnm(trndir,trndir,0)) {
3886       trnlnm_iter_count++;
3887       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3888       trnlen = strlen(trndir);
3889
3890       /* Trap simple rooted lnms, and return lnm:[000000] */
3891       if (!strcmp(trndir+trnlen-2,".]")) {
3892         if (buf) retpath = buf;
3893         else if (ts) Newx(retpath,strlen(dir)+10,char);
3894         else retpath = __pathify_retbuf;
3895         strcpy(retpath,dir);
3896         strcat(retpath,":[000000]");
3897         return retpath;
3898       }
3899     }
3900
3901     /* At this point we do not work with *dir, but the copy in
3902      * *trndir that is modifiable.
3903      */
3904
3905     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
3906       if (*trndir == '.' && (*(trndir+1) == '\0' ||
3907                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
3908         retlen = 2 + (*(trndir+1) != '\0');
3909       else {
3910         if ( !(cp1 = strrchr(trndir,'/')) &&
3911              !(cp1 = strrchr(trndir,']')) &&
3912              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
3913         if ((cp2 = strchr(cp1,'.')) != NULL &&
3914             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3915              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3916               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3917               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3918           int ver; char *cp3;
3919
3920           /* For EFS or ODS-5 look for the last dot */
3921           if (decc_efs_charset) {
3922             cp2 = strrchr(cp1,'.');
3923           }
3924           if (vms_process_case_tolerant) {
3925               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3926                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3927                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3928                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3929                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3930                             (ver || *cp3)))))) {
3931                 set_errno(ENOTDIR);
3932                 set_vaxc_errno(RMS$_DIR);
3933                 return NULL;
3934               }
3935           }
3936           else {
3937               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
3938                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
3939                   !*(cp2+3) || *(cp2+3) != 'R' ||
3940                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3941                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3942                             (ver || *cp3)))))) {
3943                 set_errno(ENOTDIR);
3944                 set_vaxc_errno(RMS$_DIR);
3945                 return NULL;
3946               }
3947           }
3948           retlen = cp2 - trndir + 1;
3949         }
3950         else {  /* No file type present.  Treat the filename as a directory. */
3951           retlen = strlen(trndir) + 1;
3952         }
3953       }
3954       if (buf) retpath = buf;
3955       else if (ts) Newx(retpath,retlen+1,char);
3956       else retpath = __pathify_retbuf;
3957       strncpy(retpath, trndir, retlen-1);
3958       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3959         retpath[retlen-1] = '/';      /* with '/', add it. */
3960         retpath[retlen] = '\0';
3961       }
3962       else retpath[retlen-1] = '\0';
3963     }
3964     else {  /* VMS-style directory spec */
3965       char esa[NAM$C_MAXRSS+1], *cp;
3966       unsigned long int sts, cmplen, haslower;
3967       struct FAB dirfab = cc$rms_fab;
3968       struct NAM savnam, dirnam = cc$rms_nam;
3969
3970       /* If we've got an explicit filename, we can just shuffle the string. */
3971       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
3972              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
3973         if ((cp2 = strchr(cp1,'.')) != NULL) {
3974           int ver; char *cp3;
3975           if (vms_process_case_tolerant) {
3976               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3977                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3978                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3979                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3980                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3981                             (ver || *cp3)))))) {
3982                set_errno(ENOTDIR);
3983                set_vaxc_errno(RMS$_DIR);
3984                return NULL;
3985              }
3986           }
3987           else {
3988               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
3989                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
3990                   !*(cp2+3) || *(cp2+3) != 'R' ||
3991                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3992                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3993                             (ver || *cp3)))))) {
3994                set_errno(ENOTDIR);
3995                set_vaxc_errno(RMS$_DIR);
3996                return NULL;
3997              }
3998           }
3999         }
4000         else {  /* No file type, so just draw name into directory part */
4001           for (cp2 = cp1; *cp2; cp2++) ;
4002         }
4003         *cp2 = *cp1;
4004         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
4005         *cp1 = '.';
4006         /* We've now got a VMS 'path'; fall through */
4007       }
4008       dirfab.fab$b_fns = strlen(trndir);
4009       dirfab.fab$l_fna = trndir;
4010       if (trndir[dirfab.fab$b_fns-1] == ']' ||
4011           trndir[dirfab.fab$b_fns-1] == '>' ||
4012           trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4013         if (buf) retpath = buf;
4014         else if (ts) Newx(retpath,strlen(trndir)+1,char);
4015         else retpath = __pathify_retbuf;
4016         strcpy(retpath,trndir);
4017         return retpath;
4018       }
4019       dirfab.fab$l_dna = ".DIR;1";
4020       dirfab.fab$b_dns = 6;
4021       dirfab.fab$l_nam = &dirnam;
4022       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4023       dirnam.nam$l_esa = esa;
4024 #ifdef NAM$M_NO_SHORT_UPCASE
4025       if (decc_efs_case_preserve)
4026           dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4027 #endif
4028
4029       for (cp = trndir; *cp; cp++)
4030         if (islower(*cp)) { haslower = 1; break; }
4031
4032       if (!(sts = (sys$parse(&dirfab)&1))) {
4033         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4034           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4035           sts = sys$parse(&dirfab) & 1;
4036         }
4037         if (!sts) {
4038           set_errno(EVMSERR);
4039           set_vaxc_errno(dirfab.fab$l_sts);
4040           return NULL;
4041         }
4042       }
4043       else {
4044         savnam = dirnam;
4045         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
4046           if (dirfab.fab$l_sts != RMS$_FNF) {
4047             int sts1;
4048             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4049             dirfab.fab$b_dns = 0;
4050             sts1 = sys$parse(&dirfab,0,0);
4051             set_errno(EVMSERR);
4052             set_vaxc_errno(dirfab.fab$l_sts);
4053             return NULL;
4054           }
4055           dirnam = savnam; /* No; just work with potential name */
4056         }
4057       }
4058       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4059         /* Yep; check version while we're at it, if it's there. */
4060         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4061         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4062           int sts2;
4063           /* Something other than .DIR[;1].  Bzzt. */
4064           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4065           dirfab.fab$b_dns = 0;
4066           sts2 = sys$parse(&dirfab,0,0);
4067           set_errno(ENOTDIR);
4068           set_vaxc_errno(RMS$_DIR);
4069           return NULL;
4070         }
4071       }
4072       /* OK, the type was fine.  Now pull any file name into the
4073          directory path. */
4074       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4075       else {
4076         cp1 = strrchr(esa,'>');
4077         *dirnam.nam$l_type = '>';
4078       }
4079       *cp1 = '.';
4080       *(dirnam.nam$l_type + 1) = '\0';
4081       retlen = dirnam.nam$l_type - esa + 2;
4082       if (buf) retpath = buf;
4083       else if (ts) Newx(retpath,retlen,char);
4084       else retpath = __pathify_retbuf;
4085       strcpy(retpath,esa);
4086       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4087       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4088       /* $PARSE may have upcased filespec, so convert output to lower
4089        * case if input contained any lowercase characters. */
4090       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4091     }
4092
4093     return retpath;
4094 }  /* end of do_pathify_dirspec() */
4095 /*}}}*/
4096 /* External entry points */
4097 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4098 { return do_pathify_dirspec(dir,buf,0); }
4099 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4100 { return do_pathify_dirspec(dir,buf,1); }
4101
4102 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
4103 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4104 {
4105   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4106   char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4107   const char *cp2;
4108   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4109   int expand = 1; /* guarantee room for leading and trailing slashes */
4110   unsigned short int trnlnm_iter_count;
4111   int cmp_rslt;
4112
4113   if (spec == NULL) return NULL;
4114   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4115   if (buf) rslt = buf;
4116   else if (ts) {
4117     retlen = strlen(spec);
4118     cp1 = strchr(spec,'[');
4119     if (!cp1) cp1 = strchr(spec,'<');
4120     if (cp1) {
4121       for (cp1++; *cp1; cp1++) {
4122         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
4123         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4124           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4125       }
4126     }
4127     Newx(rslt,retlen+2+2*expand,char);
4128   }
4129   else rslt = __tounixspec_retbuf;
4130
4131   cmp_rslt = 0; /* Presume VMS */
4132   cp1 = strchr(spec, '/');
4133   if (cp1 == NULL)
4134     cmp_rslt = 0;
4135
4136     /* Look for EFS ^/ */
4137     if (decc_efs_charset) {
4138       while (cp1 != NULL) {
4139         cp2 = cp1 - 1;
4140         if (*cp2 != '^') {
4141           /* Found illegal VMS, assume UNIX */
4142           cmp_rslt = 1;
4143           break;
4144         }
4145       cp1++;
4146       cp1 = strchr(cp1, '/');
4147     }
4148   }
4149
4150   /* Look for "." and ".." */
4151   if (decc_filename_unix_report) {
4152     if (spec[0] == '.') {
4153       if ((spec[1] == '\0') || (spec[1] == '\n')) {
4154         cmp_rslt = 1;
4155       }
4156       else {
4157         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
4158           cmp_rslt = 1;
4159         }
4160       }
4161     }
4162   }
4163   /* This is already UNIX or at least nothing VMS understands */
4164   if (cmp_rslt) {
4165     strcpy(rslt,spec);
4166     return rslt;
4167   }
4168
4169   cp1 = rslt;
4170   cp2 = spec;
4171   dirend = strrchr(spec,']');
4172   if (dirend == NULL) dirend = strrchr(spec,'>');
4173   if (dirend == NULL) dirend = strchr(spec,':');
4174   if (dirend == NULL) {
4175     strcpy(rslt,spec);
4176     return rslt;
4177   }
4178
4179   /* Special case 1 - sys$posix_root = / */
4180 #if __CRTL_VER >= 70000000
4181   if (!decc_disable_posix_root) {
4182     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
4183       *cp1 = '/';
4184       cp1++;
4185       cp2 = cp2 + 15;
4186       }
4187   }
4188 #endif
4189
4190   /* Special case 2 - Convert NLA0: to /dev/null */
4191 #if __CRTL_VER < 70000000
4192   cmp_rslt = strncmp(spec,"NLA0:", 5);
4193   if (cmp_rslt != 0)
4194      cmp_rslt = strncmp(spec,"nla0:", 5);
4195 #else
4196   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
4197 #endif
4198   if (cmp_rslt == 0) {
4199     strcpy(rslt, "/dev/null");
4200     cp1 = cp1 + 9;
4201     cp2 = cp2 + 5;
4202     if (spec[6] != '\0') {
4203       cp1[9] == '/';
4204       cp1++;
4205       cp2++;
4206     }
4207   }
4208
4209    /* Also handle special case "SYS$SCRATCH:" */
4210 #if __CRTL_VER < 70000000
4211   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
4212   if (cmp_rslt != 0)
4213      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
4214 #else
4215   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
4216 #endif
4217   if (cmp_rslt == 0) {
4218   int islnm;
4219
4220     islnm = my_trnlnm(tmp, "TMP", 0);
4221     if (!islnm) {
4222       strcpy(rslt, "/tmp");
4223       cp1 = cp1 + 4;
4224       cp2 = cp2 + 12;
4225       if (spec[12] != '\0') {
4226         cp1[4] == '/';
4227         cp1++;
4228         cp2++;
4229       }
4230     }
4231   }
4232
4233   if (*cp2 != '[' && *cp2 != '<') {
4234     *(cp1++) = '/';
4235   }
4236   else {  /* the VMS spec begins with directories */
4237     cp2++;
4238     if (*cp2 == ']' || *cp2 == '>') {
4239       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
4240       return rslt;
4241     }
4242     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
4243       if (getcwd(tmp,sizeof tmp,1) == NULL) {
4244         if (ts) Safefree(rslt);
4245         return NULL;
4246       }
4247       trnlnm_iter_count = 0;
4248       do {
4249         cp3 = tmp;
4250         while (*cp3 != ':' && *cp3) cp3++;
4251         *(cp3++) = '\0';
4252         if (strchr(cp3,']') != NULL) break;
4253         trnlnm_iter_count++;
4254         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
4255       } while (vmstrnenv(tmp,tmp,0,fildev,0));
4256       if (ts && !buf &&
4257           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
4258         retlen = devlen + dirlen;
4259         Renew(rslt,retlen+1+2*expand,char);
4260         cp1 = rslt;
4261       }
4262       cp3 = tmp;
4263       *(cp1++) = '/';
4264       while (*cp3) {
4265         *(cp1++) = *(cp3++);
4266         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
4267       }
4268       *(cp1++) = '/';
4269     }
4270     if ((*cp2 == '^')) {
4271         /* EFS file escape, pass the next character as is */
4272         /* Fix me: HEX encoding for UNICODE not implemented */
4273         cp2++;
4274     }
4275     else if ( *cp2 == '.') {
4276       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
4277         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4278         cp2 += 3;
4279       }
4280       else cp2++;
4281     }
4282   }
4283   for (; cp2 <= dirend; cp2++) {
4284     if ((*cp2 == '^')) {
4285         /* EFS file escape, pass the next character as is */
4286         /* Fix me: HEX encoding for UNICODE not implemented */
4287         cp2++;
4288         *(cp1++) = *cp2;
4289     }
4290     if (*cp2 == ':') {
4291       *(cp1++) = '/';
4292       if (*(cp2+1) == '[') cp2++;
4293     }
4294     else if (*cp2 == ']' || *cp2 == '>') {
4295       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
4296     }
4297     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
4298       *(cp1++) = '/';
4299       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
4300         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
4301                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
4302         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
4303             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
4304       }
4305       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
4306         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
4307         cp2 += 2;
4308       }
4309     }
4310     else if (*cp2 == '-') {
4311       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
4312         while (*cp2 == '-') {
4313           cp2++;
4314           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4315         }
4316         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
4317           if (ts) Safefree(rslt);                        /* filespecs like */
4318           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
4319           return NULL;
4320         }
4321       }
4322       else *(cp1++) = *cp2;
4323     }
4324     else *(cp1++) = *cp2;
4325   }
4326   while (*cp2) *(cp1++) = *(cp2++);
4327   *cp1 = '\0';
4328
4329   /* This still leaves /000000/ when working with a
4330    * VMS device root or concealed root.
4331    */
4332   {
4333   int ulen;
4334   char * zeros;
4335
4336       ulen = strlen(rslt);
4337
4338       /* Get rid of "000000/ in rooted filespecs */
4339       if (ulen > 7) {
4340         zeros = strstr(rslt, "/000000/");
4341         if (zeros != NULL) {
4342           int mlen;
4343           mlen = ulen - (zeros - rslt) - 7;
4344           memmove(zeros, &zeros[7], mlen);
4345           ulen = ulen - 7;
4346           rslt[ulen] = '\0';
4347         }
4348       }
4349   }
4350
4351   return rslt;
4352
4353 }  /* end of do_tounixspec() */
4354 /*}}}*/
4355 /* External entry points */
4356 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
4357 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
4358
4359 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
4360 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
4361   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
4362   char *rslt, *dirend;
4363   char *lastdot;
4364   char *vms_delim;
4365   register char *cp1;
4366   const char *cp2;
4367   unsigned long int infront = 0, hasdir = 1;
4368   int rslt_len;
4369   int no_type_seen;
4370
4371   if (path == NULL) return NULL;
4372   if (buf) rslt = buf;
4373   else if (ts) Newx(rslt,strlen(path)+9,char);
4374   else rslt = __tovmsspec_retbuf;
4375   if (strpbrk(path,"]:>") ||
4376       (dirend = strrchr(path,'/')) == NULL) {
4377     if (path[0] == '.') {
4378       if (path[1] == '\0') strcpy(rslt,"[]");
4379       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
4380       else strcpy(rslt,path); /* probably garbage */
4381     }
4382     else strcpy(rslt,path);
4383     return rslt;
4384   }
4385
4386   vms_delim = strpbrk(path,"]:>");
4387
4388
4389   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
4390     if (!*(dirend+2)) dirend +=2;
4391     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
4392     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
4393   }
4394
4395   cp1 = rslt;
4396   cp2 = path;
4397   lastdot = strrchr(cp2,'.');
4398   if (*cp2 == '/') {
4399     char trndev[NAM$C_MAXRSS+1];
4400     int islnm, rooted;
4401     STRLEN trnend;
4402
4403     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
4404     if (!*(cp2+1)) {
4405       if (!buf & ts) Renew(rslt,18,char);
4406       if (decc_disable_posix_root) {
4407         strcpy(rslt,"sys$disk:[000000]");
4408       }
4409       else {
4410         strcpy(rslt,"sys$posix_root:[000000]");
4411       }
4412       return rslt;
4413     }
4414     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
4415     *cp1 = '\0';
4416     islnm =  my_trnlnm(rslt,trndev,0);
4417
4418      /* DECC special handling */
4419     if (!islnm) {
4420       if (strcmp(rslt,"bin") == 0) {
4421         strcpy(rslt,"sys$system");
4422         cp1 = rslt + 10;
4423         *cp1 = 0;
4424         islnm =  my_trnlnm(rslt,trndev,0);
4425       }
4426       else if (strcmp(rslt,"tmp") == 0) {
4427         strcpy(rslt,"sys$scratch");
4428         cp1 = rslt + 11;
4429         *cp1 = 0;
4430         islnm =  my_trnlnm(rslt,trndev,0);
4431       }
4432       else if (!decc_disable_posix_root) {
4433         strcpy(rslt, "sys$posix_root");
4434         cp1 = rslt + 13;
4435         *cp1 = 0;
4436         cp2 = path;
4437         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
4438         islnm =  my_trnlnm(rslt,trndev,0);
4439       }
4440       else if (strcmp(rslt,"dev") == 0) {
4441         if (strncmp(cp2,"/null", 5) == 0) {
4442           if ((cp2[5] == 0) || (cp2[5] == '/')) {
4443             strcpy(rslt,"NLA0");
4444             cp1 = rslt + 4;
4445             *cp1 = 0;
4446             cp2 = cp2 + 5;
4447             islnm =  my_trnlnm(rslt,trndev,0);
4448           }
4449         }
4450       }
4451     }
4452
4453     trnend = islnm ? strlen(trndev) - 1 : 0;
4454     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
4455     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
4456     /* If the first element of the path is a logical name, determine
4457      * whether it has to be translated so we can add more directories. */
4458     if (!islnm || rooted) {
4459       *(cp1++) = ':';
4460       *(cp1++) = '[';
4461       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
4462       else cp2++;
4463     }
4464     else {
4465       if (cp2 != dirend) {
4466         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
4467         strcpy(rslt,trndev);
4468         cp1 = rslt + trnend;
4469         if (*cp2 != 0) {
4470           *(cp1++) = '.';
4471           cp2++;
4472         }
4473       }
4474       else {
4475         if (decc_disable_posix_root) {
4476           *(cp1++) = ':';
4477           hasdir = 0;
4478         }
4479       }
4480     }
4481   }
4482   else {
4483     *(cp1++) = '[';
4484     if (*cp2 == '.') {
4485       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
4486         cp2 += 2;         /* skip over "./" - it's redundant */
4487         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
4488       }
4489       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4490         *(cp1++) = '-';                                 /* "../" --> "-" */
4491         cp2 += 3;
4492       }
4493       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
4494                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
4495         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4496         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
4497         cp2 += 4;
4498       }
4499       else if ((cp2 != lastdot) || (lastdot < dirend)) {
4500         /* Escape the extra dots in EFS file specifications */
4501         *(cp1++) = '^';
4502       }
4503       if (cp2 > dirend) cp2 = dirend;
4504     }
4505     else *(cp1++) = '.';
4506   }
4507   for (; cp2 < dirend; cp2++) {
4508     if (*cp2 == '/') {
4509       if (*(cp2-1) == '/') continue;
4510       if (*(cp1-1) != '.') *(cp1++) = '.';
4511       infront = 0;
4512     }
4513     else if (!infront && *cp2 == '.') {
4514       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
4515       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
4516       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4517         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
4518         else if (*(cp1-2) == '[') *(cp1-1) = '-';
4519         else {  /* back up over previous directory name */
4520           cp1--;
4521           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4522           if (*(cp1-1) == '[') {
4523             memcpy(cp1,"000000.",7);
4524             cp1 += 7;
4525           }
4526         }
4527         cp2 += 2;
4528         if (cp2 == dirend) break;
4529       }
4530       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
4531                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
4532         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
4533         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4534         if (!*(cp2+3)) {
4535           *(cp1++) = '.';  /* Simulate trailing '/' */
4536           cp2 += 2;  /* for loop will incr this to == dirend */
4537         }
4538         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
4539       }
4540       else {
4541         if (decc_efs_charset == 0)
4542           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
4543         else {
4544           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
4545           *(cp1++) = '.';
4546         }
4547       }
4548     }
4549     else {
4550       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
4551       if (*cp2 == '.') {
4552         if (decc_efs_charset == 0)
4553           *(cp1++) = '_';
4554         else {
4555           *(cp1++) = '^';
4556           *(cp1++) = '.';
4557         }
4558       }
4559       else                  *(cp1++) =  *cp2;
4560       infront = 1;
4561     }
4562   }
4563   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
4564   if (hasdir) *(cp1++) = ']';
4565   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
4566   /* fixme for ODS5 */
4567   no_type_seen = 0;
4568   if (cp2 > lastdot)
4569     no_type_seen = 1;
4570   while (*cp2) {
4571     switch(*cp2) {
4572     case '?':
4573         *(cp1++) = '%';
4574         cp2++;
4575     case ' ':
4576         *(cp1)++ = '^';
4577         *(cp1)++ = '_';
4578         cp2++;
4579         break;
4580     case '.':
4581         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
4582             decc_readdir_dropdotnotype) {
4583           *(cp1)++ = '^';
4584           *(cp1)++ = '.';
4585           cp2++;
4586
4587           /* trailing dot ==> '^..' on VMS */
4588           if (*cp2 == '\0') {
4589             *(cp1++) = '.';
4590             no_type_seen = 0;
4591           }
4592         }
4593         else {
4594           *(cp1++) = *(cp2++);
4595           no_type_seen = 0;
4596         }
4597         break;
4598     case '\"':
4599     case '~':
4600     case '`':
4601     case '!':
4602     case '#':
4603     case '%':
4604     case '^':
4605     case '&':
4606     case '(':
4607     case ')':
4608     case '=':
4609     case '+':
4610     case '\'':
4611     case '@':
4612     case '[':
4613     case ']':
4614     case '{':
4615     case '}':
4616     case ':':
4617     case '\\':
4618     case '|':
4619     case '<':
4620     case '>':
4621         *(cp1++) = '^';
4622         *(cp1++) = *(cp2++);
4623         break;
4624     case ';':
4625         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
4626          * which is wrong.  UNIX notation should be ".dir. unless
4627          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
4628          * changing this behavior could break more things at this time.
4629          */
4630         if (decc_filename_unix_report != 0) {
4631           *(cp1++) = '^';
4632         }
4633         *(cp1++) = *(cp2++);
4634         break;
4635     default:
4636         *(cp1++) = *(cp2++);
4637     }
4638   }
4639   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
4640   char *lcp1;
4641     lcp1 = cp1;
4642     lcp1--;
4643      /* Fix me for "^]", but that requires making sure that you do
4644       * not back up past the start of the filename
4645       */
4646     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
4647       *cp1++ = '.';
4648   }
4649   *cp1 = '\0';
4650
4651   return rslt;
4652
4653 }  /* end of do_tovmsspec() */
4654 /*}}}*/
4655 /* External entry points */
4656 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
4657 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
4658
4659 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
4660 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
4661   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
4662   int vmslen;
4663   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
4664
4665   if (path == NULL) return NULL;
4666   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4667   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
4668   if (buf) return buf;
4669   else if (ts) {
4670     vmslen = strlen(vmsified);
4671     Newx(cp,vmslen+1,char);
4672     memcpy(cp,vmsified,vmslen);
4673     cp[vmslen] = '\0';
4674     return cp;
4675   }
4676   else {
4677     strcpy(__tovmspath_retbuf,vmsified);
4678     return __tovmspath_retbuf;
4679   }
4680
4681 }  /* end of do_tovmspath() */
4682 /*}}}*/
4683 /* External entry points */
4684 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
4685 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
4686
4687
4688 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
4689 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
4690   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
4691   int unixlen;
4692   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
4693
4694   if (path == NULL) return NULL;
4695   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4696   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
4697   if (buf) return buf;
4698   else if (ts) {
4699     unixlen = strlen(unixified);
4700     Newx(cp,unixlen+1,char);
4701     memcpy(cp,unixified,unixlen);
4702     cp[unixlen] = '\0';
4703     return cp;
4704   }
4705   else {
4706     strcpy(__tounixpath_retbuf,unixified);
4707     return __tounixpath_retbuf;
4708   }
4709
4710 }  /* end of do_tounixpath() */
4711 /*}}}*/
4712 /* External entry points */
4713 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
4714 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
4715
4716 /*
4717  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
4718  *
4719  *****************************************************************************
4720  *                                                                           *
4721  *  Copyright (C) 1989-1994 by                                               *
4722  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
4723  *                                                                           *
4724  *  Permission is hereby  granted for the reproduction of this software,     *
4725  *  on condition that this copyright notice is included in the reproduction, *
4726  *  and that such reproduction is not for purposes of profit or material     *
4727  *  gain.                                                                    *
4728  *                                                                           *
4729  *  27-Aug-1994 Modified for inclusion in perl5                              *
4730  *              by Charles Bailey  bailey@newman.upenn.edu                   *
4731  *****************************************************************************
4732  */
4733
4734 /*
4735  * getredirection() is intended to aid in porting C programs
4736  * to VMS (Vax-11 C).  The native VMS environment does not support
4737  * '>' and '<' I/O redirection, or command line wild card expansion,
4738  * or a command line pipe mechanism using the '|' AND background
4739  * command execution '&'.  All of these capabilities are provided to any
4740  * C program which calls this procedure as the first thing in the
4741  * main program.
4742  * The piping mechanism will probably work with almost any 'filter' type
4743  * of program.  With suitable modification, it may useful for other
4744  * portability problems as well.
4745  *
4746  * Author:  Mark Pizzolato      mark@infocomm.com
4747  */
4748 struct list_item
4749     {
4750     struct list_item *next;
4751     char *value;
4752     };
4753
4754 static void add_item(struct list_item **head,
4755                      struct list_item **tail,
4756                      char *value,
4757                      int *count);
4758
4759 static void mp_expand_wild_cards(pTHX_ char *item,
4760                                 struct list_item **head,
4761                                 struct list_item **tail,
4762                                 int *count);
4763
4764 static int background_process(pTHX_ int argc, char **argv);
4765
4766 static void pipe_and_fork(pTHX_ char **cmargv);
4767
4768 /*{{{ void getredirection(int *ac, char ***av)*/
4769 static void
4770 mp_getredirection(pTHX_ int *ac, char ***av)
4771 /*
4772  * Process vms redirection arg's.  Exit if any error is seen.
4773  * If getredirection() processes an argument, it is erased
4774  * from the vector.  getredirection() returns a new argc and argv value.
4775  * In the event that a background command is requested (by a trailing "&"),
4776  * this routine creates a background subprocess, and simply exits the program.
4777  *
4778  * Warning: do not try to simplify the code for vms.  The code
4779  * presupposes that getredirection() is called before any data is
4780  * read from stdin or written to stdout.
4781  *
4782  * Normal usage is as follows:
4783  *
4784  *      main(argc, argv)
4785  *      int             argc;
4786  *      char            *argv[];
4787  *      {
4788  *              getredirection(&argc, &argv);
4789  *      }
4790  */
4791 {
4792     int                 argc = *ac;     /* Argument Count         */
4793     char                **argv = *av;   /* Argument Vector        */
4794     char                *ap;            /* Argument pointer       */
4795     int                 j;              /* argv[] index           */
4796     int                 item_count = 0; /* Count of Items in List */
4797     struct list_item    *list_head = 0; /* First Item in List       */
4798     struct list_item    *list_tail;     /* Last Item in List        */
4799     char                *in = NULL;     /* Input File Name          */
4800     char                *out = NULL;    /* Output File Name         */
4801     char                *outmode = "w"; /* Mode to Open Output File */
4802     char                *err = NULL;    /* Error File Name          */
4803     char                *errmode = "w"; /* Mode to Open Error File  */
4804     int                 cmargc = 0;     /* Piped Command Arg Count  */
4805     char                **cmargv = NULL;/* Piped Command Arg Vector */
4806
4807     /*
4808      * First handle the case where the last thing on the line ends with
4809      * a '&'.  This indicates the desire for the command to be run in a
4810      * subprocess, so we satisfy that desire.
4811      */
4812     ap = argv[argc-1];
4813     if (0 == strcmp("&", ap))
4814        exit(background_process(aTHX_ --argc, argv));
4815     if (*ap && '&' == ap[strlen(ap)-1])
4816         {
4817         ap[strlen(ap)-1] = '\0';
4818        exit(background_process(aTHX_ argc, argv));
4819         }
4820     /*
4821      * Now we handle the general redirection cases that involve '>', '>>',
4822      * '<', and pipes '|'.
4823      */
4824     for (j = 0; j < argc; ++j)
4825         {
4826         if (0 == strcmp("<", argv[j]))
4827             {
4828             if (j+1 >= argc)
4829                 {
4830                 fprintf(stderr,"No input file after < on command line");
4831                 exit(LIB$_WRONUMARG);
4832                 }
4833             in = argv[++j];
4834             continue;
4835             }
4836         if ('<' == *(ap = argv[j]))
4837             {
4838             in = 1 + ap;
4839             continue;
4840             }
4841         if (0 == strcmp(">", ap))
4842             {
4843             if (j+1 >= argc)
4844                 {
4845                 fprintf(stderr,"No output file after > on command line");
4846                 exit(LIB$_WRONUMARG);
4847                 }
4848             out = argv[++j];
4849             continue;
4850             }
4851         if ('>' == *ap)
4852             {
4853             if ('>' == ap[1])
4854                 {
4855                 outmode = "a";
4856                 if ('\0' == ap[2])
4857                     out = argv[++j];
4858                 else
4859                     out = 2 + ap;
4860                 }
4861             else
4862                 out = 1 + ap;
4863             if (j >= argc)
4864                 {
4865                 fprintf(stderr,"No output file after > or >> on command line");
4866                 exit(LIB$_WRONUMARG);
4867                 }
4868             continue;
4869             }
4870         if (('2' == *ap) && ('>' == ap[1]))
4871             {
4872             if ('>' == ap[2])
4873                 {
4874                 errmode = "a";
4875                 if ('\0' == ap[3])
4876                     err = argv[++j];
4877                 else
4878                     err = 3 + ap;
4879                 }
4880             else
4881                 if ('\0' == ap[2])
4882                     err = argv[++j];
4883                 else
4884                     err = 2 + ap;
4885             if (j >= argc)
4886                 {
4887                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4888                 exit(LIB$_WRONUMARG);
4889                 }
4890             continue;
4891             }
4892         if (0 == strcmp("|", argv[j]))
4893             {
4894             if (j+1 >= argc)
4895                 {
4896                 fprintf(stderr,"No command into which to pipe on command line");
4897                 exit(LIB$_WRONUMARG);
4898                 }
4899             cmargc = argc-(j+1);
4900             cmargv = &argv[j+1];
4901             argc = j;
4902             continue;
4903             }
4904         if ('|' == *(ap = argv[j]))
4905             {
4906             ++argv[j];
4907             cmargc = argc-j;
4908             cmargv = &argv[j];
4909             argc = j;
4910             continue;
4911             }
4912         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4913         }
4914     /*
4915      * Allocate and fill in the new argument vector, Some Unix's terminate
4916      * the list with an extra null pointer.
4917      */
4918     Newx(argv, item_count+1, char *);
4919     *av = argv;
4920     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4921         argv[j] = list_head->value;
4922     *ac = item_count;
4923     if (cmargv != NULL)
4924         {
4925         if (out != NULL)
4926             {
4927             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4928             exit(LIB$_INVARGORD);
4929             }
4930         pipe_and_fork(aTHX_ cmargv);
4931         }
4932
4933     /* Check for input from a pipe (mailbox) */
4934
4935     if (in == NULL && 1 == isapipe(0))
4936         {
4937         char mbxname[L_tmpnam];
4938         long int bufsize;
4939         long int dvi_item = DVI$_DEVBUFSIZ;
4940         $DESCRIPTOR(mbxnam, "");
4941         $DESCRIPTOR(mbxdevnam, "");
4942
4943         /* Input from a pipe, reopen it in binary mode to disable       */
4944         /* carriage control processing.                                 */
4945
4946         fgetname(stdin, mbxname);
4947         mbxnam.dsc$a_pointer = mbxname;
4948         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4949         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4950         mbxdevnam.dsc$a_pointer = mbxname;
4951         mbxdevnam.dsc$w_length = sizeof(mbxname);
4952         dvi_item = DVI$_DEVNAM;
4953         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4954         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4955         set_errno(0);
4956         set_vaxc_errno(1);
4957         freopen(mbxname, "rb", stdin);
4958         if (errno != 0)
4959             {
4960             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4961             exit(vaxc$errno);
4962             }
4963         }
4964     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4965         {
4966         fprintf(stderr,"Can't open input file %s as stdin",in);
4967         exit(vaxc$errno);
4968         }
4969     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4970         {
4971         fprintf(stderr,"Can't open output file %s as stdout",out);
4972         exit(vaxc$errno);
4973         }
4974         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4975
4976     if (err != NULL) {
4977         if (strcmp(err,"&1") == 0) {
4978             dup2(fileno(stdout), fileno(stderr));
4979             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4980         } else {
4981         FILE *tmperr;
4982         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4983             {
4984             fprintf(stderr,"Can't open error file %s as stderr",err);
4985             exit(vaxc$errno);
4986             }
4987             fclose(tmperr);
4988            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4989                 {
4990                 exit(vaxc$errno);
4991                 }
4992             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4993         }
4994         }
4995 #ifdef ARGPROC_DEBUG
4996     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4997     for (j = 0; j < *ac;  ++j)
4998         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4999 #endif
5000    /* Clear errors we may have hit expanding wildcards, so they don't
5001       show up in Perl's $! later */
5002    set_errno(0); set_vaxc_errno(1);
5003 }  /* end of getredirection() */
5004 /*}}}*/
5005
5006 static void add_item(struct list_item **head,
5007                      struct list_item **tail,
5008                      char *value,
5009                      int *count)
5010 {
5011     if (*head == 0)
5012         {
5013         Newx(*head,1,struct list_item);
5014         *tail = *head;
5015         }
5016     else {
5017         Newx((*tail)->next,1,struct list_item);
5018         *tail = (*tail)->next;
5019         }
5020     (*tail)->value = value;
5021     ++(*count);
5022 }
5023
5024 static void mp_expand_wild_cards(pTHX_ char *item,
5025                               struct list_item **head,
5026                               struct list_item **tail,
5027                               int *count)
5028 {
5029 int expcount = 0;
5030 unsigned long int context = 0;
5031 int isunix = 0;
5032 int item_len = 0;
5033 char *had_version;
5034 char *had_device;
5035 int had_directory;
5036 char *devdir,*cp;
5037 char vmsspec[NAM$C_MAXRSS+1];
5038 $DESCRIPTOR(filespec, "");
5039 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
5040 $DESCRIPTOR(resultspec, "");
5041 unsigned long int zero = 0, sts;
5042
5043     for (cp = item; *cp; cp++) {
5044         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
5045         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
5046     }
5047     if (!*cp || isspace(*cp))
5048         {
5049         add_item(head, tail, item, count);
5050         return;
5051         }
5052     else
5053         {
5054      /* "double quoted" wild card expressions pass as is */
5055      /* From DCL that means using e.g.:                  */
5056      /* perl program """perl.*"""                        */
5057      item_len = strlen(item);
5058      if ( '"' == *item && '"' == item[item_len-1] )
5059        {
5060        item++;
5061        item[item_len-2] = '\0';
5062        add_item(head, tail, item, count);
5063        return;
5064        }
5065      }
5066     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
5067     resultspec.dsc$b_class = DSC$K_CLASS_D;
5068     resultspec.dsc$a_pointer = NULL;
5069     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
5070       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
5071     if (!isunix || !filespec.dsc$a_pointer)
5072       filespec.dsc$a_pointer = item;
5073     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
5074     /*
5075      * Only return version specs, if the caller specified a version
5076      */
5077     had_version = strchr(item, ';');
5078     /*
5079      * Only return device and directory specs, if the caller specifed either.
5080      */
5081     had_device = strchr(item, ':');
5082     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
5083
5084     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
5085                                   &defaultspec, 0, 0, &zero))))
5086         {
5087         char *string;
5088         char *c;
5089
5090         Newx(string,resultspec.dsc$w_length+1,char);
5091         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
5092         string[resultspec.dsc$w_length] = '\0';
5093         if (NULL == had_version)
5094             *(strrchr(string, ';')) = '\0';
5095         if ((!had_directory) && (had_device == NULL))
5096             {
5097             if (NULL == (devdir = strrchr(string, ']')))
5098                 devdir = strrchr(string, '>');
5099             strcpy(string, devdir + 1);
5100             }
5101         /*
5102          * Be consistent with what the C RTL has already done to the rest of
5103          * the argv items and lowercase all of these names.
5104          */
5105         if (!decc_efs_case_preserve) {
5106             for (c = string; *c; ++c)
5107             if (isupper(*c))
5108                 *c = tolower(*c);
5109         }
5110         if (isunix) trim_unixpath(string,item,1);
5111         add_item(head, tail, string, count);
5112         ++expcount;
5113         }
5114     if (sts != RMS$_NMF)
5115         {
5116         set_vaxc_errno(sts);
5117         switch (sts)
5118             {
5119             case RMS$_FNF: case RMS$_DNF:
5120                 set_errno(ENOENT); break;
5121             case RMS$_DIR:
5122                 set_errno(ENOTDIR); break;
5123             case RMS$_DEV:
5124                 set_errno(ENODEV); break;
5125             case RMS$_FNM: case RMS$_SYN:
5126                 set_errno(EINVAL); break;
5127             case RMS$_PRV:
5128                 set_errno(EACCES); break;
5129             default:
5130                 _ckvmssts_noperl(sts);
5131             }
5132         }
5133     if (expcount == 0)
5134         add_item(head, tail, item, count);
5135     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
5136     _ckvmssts_noperl(lib$find_file_end(&context));
5137 }
5138
5139 static int child_st[2];/* Event Flag set when child process completes   */
5140
5141 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
5142
5143 static unsigned long int exit_handler(int *status)
5144 {
5145 short iosb[4];
5146
5147     if (0 == child_st[0])
5148         {
5149 #ifdef ARGPROC_DEBUG
5150         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
5151 #endif
5152         fflush(stdout);     /* Have to flush pipe for binary data to    */
5153                             /* terminate properly -- <tp@mccall.com>    */
5154         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
5155         sys$dassgn(child_chan);
5156         fclose(stdout);
5157         sys$synch(0, child_st);
5158         }
5159     return(1);
5160 }
5161
5162 static void sig_child(int chan)
5163 {
5164 #ifdef ARGPROC_DEBUG
5165     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
5166 #endif
5167     if (child_st[0] == 0)
5168         child_st[0] = 1;
5169 }
5170
5171 static struct exit_control_block exit_block =
5172     {
5173     0,
5174     exit_handler,
5175     1,
5176     &exit_block.exit_status,
5177     0
5178     };
5179
5180 static void
5181 pipe_and_fork(pTHX_ char **cmargv)
5182 {
5183     PerlIO *fp;
5184     struct dsc$descriptor_s *vmscmd;
5185     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
5186     int sts, j, l, ismcr, quote, tquote = 0;
5187
5188     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
5189     vms_execfree(vmscmd);
5190
5191     j = l = 0;
5192     p = subcmd;
5193     q = cmargv[0];
5194     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
5195               && toupper(*(q+2)) == 'R' && !*(q+3);
5196
5197     while (q && l < MAX_DCL_LINE_LENGTH) {
5198         if (!*q) {
5199             if (j > 0 && quote) {
5200                 *p++ = '"';
5201                 l++;
5202             }
5203             q = cmargv[++j];
5204             if (q) {
5205                 if (ismcr && j > 1) quote = 1;
5206                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
5207                 *p++ = ' ';
5208                 l++;
5209                 if (quote || tquote) {
5210                     *p++ = '"';
5211                     l++;
5212                 }
5213         }
5214         } else {
5215             if ((quote||tquote) && *q == '"') {
5216                 *p++ = '"';
5217                 l++;
5218         }
5219             *p++ = *q++;
5220             l++;
5221         }
5222     }
5223     *p = '\0';
5224
5225     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
5226     if (fp == Nullfp) {
5227         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
5228         }
5229 }
5230
5231 static int background_process(pTHX_ int argc, char **argv)
5232 {
5233 char command[2048] = "$";
5234 $DESCRIPTOR(value, "");
5235 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
5236 static $DESCRIPTOR(null, "NLA0:");
5237 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
5238 char pidstring[80];
5239 $DESCRIPTOR(pidstr, "");
5240 int pid;
5241 unsigned long int flags = 17, one = 1, retsts;
5242
5243     strcat(command, argv[0]);
5244     while (--argc)
5245         {
5246         strcat(command, " \"");
5247         strcat(command, *(++argv));
5248         strcat(command, "\"");
5249         }
5250     value.dsc$a_pointer = command;
5251     value.dsc$w_length = strlen(value.dsc$a_pointer);
5252     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
5253     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
5254     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
5255         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
5256     }
5257     else {
5258         _ckvmssts_noperl(retsts);
5259     }
5260 #ifdef ARGPROC_DEBUG
5261     PerlIO_printf(Perl_debug_log, "%s\n", command);
5262 #endif
5263     sprintf(pidstring, "%08X", pid);
5264     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
5265     pidstr.dsc$a_pointer = pidstring;
5266     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
5267     lib$set_symbol(&pidsymbol, &pidstr);
5268     return(SS$_NORMAL);
5269 }
5270 /*}}}*/
5271 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
5272
5273
5274 /* OS-specific initialization at image activation (not thread startup) */
5275 /* Older VAXC header files lack these constants */
5276 #ifndef JPI$_RIGHTS_SIZE
5277 #  define JPI$_RIGHTS_SIZE 817
5278 #endif
5279 #ifndef KGB$M_SUBSYSTEM
5280 #  define KGB$M_SUBSYSTEM 0x8
5281 #endif
5282
5283 /*{{{void vms_image_init(int *, char ***)*/
5284 void
5285 vms_image_init(int *argcp, char ***argvp)
5286 {
5287   char eqv[LNM$C_NAMLENGTH+1] = "";
5288   unsigned int len, tabct = 8, tabidx = 0;
5289   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
5290   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
5291   unsigned short int dummy, rlen;
5292   struct dsc$descriptor_s **tabvec;
5293 #if defined(PERL_IMPLICIT_CONTEXT)
5294   pTHX = NULL;
5295 #endif
5296   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
5297                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
5298                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
5299                                  {          0,                0,    0,      0} };
5300
5301 #ifdef KILL_BY_SIGPRC
5302     Perl_csighandler_init();
5303 #endif
5304
5305   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
5306   _ckvmssts_noperl(iosb[0]);
5307   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
5308     if (iprv[i]) {           /* Running image installed with privs? */
5309       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
5310       will_taint = TRUE;
5311       break;
5312     }
5313   }
5314   /* Rights identifiers might trigger tainting as well. */
5315   if (!will_taint && (rlen || rsz)) {
5316     while (rlen < rsz) {
5317       /* We didn't get all the identifiers on the first pass.  Allocate a
5318        * buffer much larger than $GETJPI wants (rsz is size in bytes that
5319        * were needed to hold all identifiers at time of last call; we'll
5320        * allocate that many unsigned long ints), and go back and get 'em.
5321        * If it gave us less than it wanted to despite ample buffer space,
5322        * something's broken.  Is your system missing a system identifier?
5323        */
5324       if (rsz <= jpilist[1].buflen) {
5325          /* Perl_croak accvios when used this early in startup. */
5326          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
5327                          rsz, (unsigned long) jpilist[1].buflen,
5328                          "Check your rights database for corruption.\n");
5329          exit(SS$_ABORT);
5330       }
5331       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
5332       jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
5333       jpilist[1].buflen = rsz * sizeof(unsigned long int);
5334       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
5335       _ckvmssts_noperl(iosb[0]);
5336     }
5337     mask = jpilist[1].bufadr;
5338     /* Check attribute flags for each identifier (2nd longword); protected
5339      * subsystem identifiers trigger tainting.
5340      */
5341     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
5342       if (mask[i] & KGB$M_SUBSYSTEM) {
5343         will_taint = TRUE;
5344         break;
5345       }
5346     }
5347     if (mask != rlst) Safefree(mask);
5348   }
5349
5350   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
5351    * logical, some versions of the CRTL will add a phanthom /000000/
5352    * directory.  This needs to be removed.
5353    */
5354   if (decc_filename_unix_report) {
5355   char * zeros;
5356   int ulen;
5357     ulen = strlen(argvp[0][0]);
5358     if (ulen > 7) {
5359       zeros = strstr(argvp[0][0], "/000000/");
5360       if (zeros != NULL) {
5361         int mlen;
5362         mlen = ulen - (zeros - argvp[0][0]) - 7;
5363         memmove(zeros, &zeros[7], mlen);
5364         ulen = ulen - 7;
5365         argvp[0][0][ulen] = '\0';
5366       }
5367     }
5368     /* It also may have a trailing dot that needs to be removed otherwise
5369      * it will be converted to VMS mode incorrectly.
5370      */
5371     ulen--;
5372     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
5373       argvp[0][0][ulen] = '\0';
5374   }
5375
5376   /* We need to use this hack to tell Perl it should run with tainting,
5377    * since its tainting flag may be part of the PL_curinterp struct, which
5378    * hasn't been allocated when vms_image_init() is called.
5379    */
5380   if (will_taint) {
5381     char **newargv, **oldargv;
5382     oldargv = *argvp;
5383     Newx(newargv,(*argcp)+2,char *);
5384     newargv[0] = oldargv[0];
5385     Newx(newargv[1],3,char);
5386     strcpy(newargv[1], "-T");
5387     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
5388     (*argcp)++;
5389     newargv[*argcp] = NULL;
5390     /* We orphan the old argv, since we don't know where it's come from,
5391      * so we don't know how to free it.
5392      */
5393     *argvp = newargv;
5394   }
5395   else {  /* Did user explicitly request tainting? */
5396     int i;
5397     char *cp, **av = *argvp;
5398     for (i = 1; i < *argcp; i++) {
5399       if (*av[i] != '-') break;
5400       for (cp = av[i]+1; *cp; cp++) {
5401         if (*cp == 'T') { will_taint = 1; break; }
5402         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
5403                   strchr("DFIiMmx",*cp)) break;
5404       }
5405       if (will_taint) break;
5406     }
5407   }
5408
5409   for (tabidx = 0;
5410        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
5411        tabidx++) {
5412     if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
5413     else if (tabidx >= tabct) {
5414       tabct += 8;
5415       Renew(tabvec,tabct,struct dsc$descriptor_s *);
5416     }
5417     Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
5418     tabvec[tabidx]->dsc$w_length  = 0;
5419     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
5420     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
5421     tabvec[tabidx]->dsc$a_pointer = NULL;
5422     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
5423   }
5424   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
5425
5426   getredirection(argcp,argvp);
5427 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
5428   {
5429 # include <reentrancy.h>
5430   decc$set_reentrancy(C$C_MULTITHREAD);
5431   }
5432 #endif
5433   return;
5434 }
5435 /*}}}*/
5436
5437
5438 /* trim_unixpath()
5439  * Trim Unix-style prefix off filespec, so it looks like what a shell
5440  * glob expansion would return (i.e. from specified prefix on, not
5441  * full path).  Note that returned filespec is Unix-style, regardless
5442  * of whether input filespec was VMS-style or Unix-style.
5443  *
5444  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
5445  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
5446  * vector of options; at present, only bit 0 is used, and if set tells
5447  * trim unixpath to try the current default directory as a prefix when
5448  * presented with a possibly ambiguous ... wildcard.
5449  *
5450  * Returns !=0 on success, with trimmed filespec replacing contents of
5451  * fspec, and 0 on failure, with contents of fpsec unchanged.
5452  */
5453 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
5454 int
5455 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
5456 {
5457   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
5458        *template, *base, *end, *cp1, *cp2;
5459   register int tmplen, reslen = 0, dirs = 0;
5460
5461   if (!wildspec || !fspec) return 0;
5462   template = unixwild;
5463   if (strpbrk(wildspec,"]>:") != NULL) {
5464     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
5465   }
5466   else {
5467     strncpy(unixwild, wildspec, NAM$C_MAXRSS);
5468     unixwild[NAM$C_MAXRSS] = 0;
5469   }
5470   if (strpbrk(fspec,"]>:") != NULL) {
5471     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
5472     else base = unixified;
5473     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
5474      * check to see that final result fits into (isn't longer than) fspec */
5475     reslen = strlen(fspec);
5476   }
5477   else base = fspec;
5478
5479   /* No prefix or absolute path on wildcard, so nothing to remove */
5480   if (!*template || *template == '/') {
5481     if (base == fspec) return 1;
5482     tmplen = strlen(unixified);
5483     if (tmplen > reslen) return 0;  /* not enough space */
5484     /* Copy unixified resultant, including trailing NUL */
5485     memmove(fspec,unixified,tmplen+1);
5486     return 1;
5487   }
5488
5489   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
5490   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
5491     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
5492     for (cp1 = end ;cp1 >= base; cp1--)
5493       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
5494         { cp1++; break; }
5495     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
5496     return 1;
5497   }
5498   else {
5499     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
5500     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
5501     int ells = 1, totells, segdirs, match;
5502     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
5503                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5504
5505     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
5506     totells = ells;
5507     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
5508     if (ellipsis == template && opts & 1) {
5509       /* Template begins with an ellipsis.  Since we can't tell how many
5510        * directory names at the front of the resultant to keep for an
5511        * arbitrary starting point, we arbitrarily choose the current
5512        * default directory as a starting point.  If it's there as a prefix,
5513        * clip it off.  If not, fall through and act as if the leading
5514        * ellipsis weren't there (i.e. return shortest possible path that
5515        * could match template).
5516        */
5517       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
5518       if (!decc_efs_case_preserve) {
5519         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5520           if (_tolower(*cp1) != _tolower(*cp2)) break;
5521       }
5522       segdirs = dirs - totells;  /* Min # of dirs we must have left */
5523       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
5524       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
5525         memcpy(fspec,cp2+1,end - cp2);
5526         return 1;
5527       }
5528     }
5529     /* First off, back up over constant elements at end of path */
5530     if (dirs) {
5531       for (front = end ; front >= base; front--)
5532          if (*front == '/' && !dirs--) { front++; break; }
5533     }
5534     if (!decc_efs_case_preserve) {
5535       for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
5536          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
5537     }
5538     if (cp1 != '\0') return 0;  /* Path too long. */
5539     lcend = cp2;
5540     *cp2 = '\0';  /* Pick up with memcpy later */
5541     lcfront = lcres + (front - base);
5542     /* Now skip over each ellipsis and try to match the path in front of it. */
5543     while (ells--) {
5544       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
5545         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
5546             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
5547       if (cp1 < template) break; /* template started with an ellipsis */
5548       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
5549         ellipsis = cp1; continue;
5550       }
5551       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
5552       nextell = cp1;
5553       for (segdirs = 0, cp2 = tpl;
5554            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
5555            cp1++, cp2++) {
5556          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
5557          else {
5558             if (!decc_efs_case_preserve) {
5559               *cp2 = _tolower(*cp1);  /* else lowercase for match */
5560             }
5561             else {
5562               *cp2 = *cp1;  /* else preserve case for match */
5563             }
5564          }
5565          if (*cp2 == '/') segdirs++;
5566       }
5567       if (cp1 != ellipsis - 1) return 0; /* Path too long */
5568       /* Back up at least as many dirs as in template before matching */
5569       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
5570         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
5571       for (match = 0; cp1 > lcres;) {
5572         resdsc.dsc$a_pointer = cp1;
5573         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
5574           match++;
5575           if (match == 1) lcfront = cp1;
5576         }
5577         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
5578       }
5579       if (!match) return 0;  /* Can't find prefix ??? */
5580       if (match > 1 && opts & 1) {
5581         /* This ... wildcard could cover more than one set of dirs (i.e.
5582          * a set of similar dir names is repeated).  If the template
5583          * contains more than 1 ..., upstream elements could resolve the
5584          * ambiguity, but it's not worth a full backtracking setup here.
5585          * As a quick heuristic, clip off the current default directory
5586          * if it's present to find the trimmed spec, else use the
5587          * shortest string that this ... could cover.
5588          */
5589         char def[NAM$C_MAXRSS+1], *st;
5590
5591         if (getcwd(def, sizeof def,0) == NULL) return 0;
5592         if (!decc_efs_case_preserve) {
5593           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5594             if (_tolower(*cp1) != _tolower(*cp2)) break;
5595         }
5596         segdirs = dirs - totells;  /* Min # of dirs we must have left */
5597         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
5598         if (*cp1 == '\0' && *cp2 == '/') {
5599           memcpy(fspec,cp2+1,end - cp2);
5600           return 1;
5601         }
5602         /* Nope -- stick with lcfront from above and keep going. */
5603       }
5604     }
5605     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
5606     return 1;
5607     ellipsis = nextell;
5608   }
5609
5610 }  /* end of trim_unixpath() */
5611 /*}}}*/
5612
5613
5614 /*
5615  *  VMS readdir() routines.
5616  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
5617  *
5618  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
5619  *  Minor modifications to original routines.
5620  */
5621
5622 /* readdir may have been redefined by reentr.h, so make sure we get
5623  * the local version for what we do here.
5624  */
5625 #ifdef readdir
5626 # undef readdir
5627 #endif
5628 #if !defined(PERL_IMPLICIT_CONTEXT)
5629 # define readdir Perl_readdir
5630 #else
5631 # define readdir(a) Perl_readdir(aTHX_ a)
5632 #endif
5633
5634     /* Number of elements in vms_versions array */
5635 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
5636
5637 /*
5638  *  Open a directory, return a handle for later use.
5639  */
5640 /*{{{ DIR *opendir(char*name) */
5641 DIR *
5642 Perl_opendir(pTHX_ const char *name)
5643 {
5644     DIR *dd;
5645     char dir[NAM$C_MAXRSS+1];
5646     Stat_t sb;
5647
5648     if (do_tovmspath(name,dir,0) == NULL) {
5649       return NULL;
5650     }
5651     /* Check access before stat; otherwise stat does not
5652      * accurately report whether it's a directory.
5653      */
5654     if (!cando_by_name(S_IRUSR,0,dir)) {
5655       /* cando_by_name has already set errno */
5656       return NULL;
5657     }
5658     if (flex_stat(dir,&sb) == -1) return NULL;
5659     if (!S_ISDIR(sb.st_mode)) {
5660       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
5661       return NULL;
5662     }
5663     /* Get memory for the handle, and the pattern. */
5664     Newx(dd,1,DIR);
5665     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
5666
5667     /* Fill in the fields; mainly playing with the descriptor. */
5668     sprintf(dd->pattern, "%s*.*",dir);
5669     dd->context = 0;
5670     dd->count = 0;
5671     dd->vms_wantversions = 0;
5672     dd->pat.dsc$a_pointer = dd->pattern;
5673     dd->pat.dsc$w_length = strlen(dd->pattern);
5674     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
5675     dd->pat.dsc$b_class = DSC$K_CLASS_S;
5676 #if defined(USE_ITHREADS)
5677     Newx(dd->mutex,1,perl_mutex);
5678     MUTEX_INIT( (perl_mutex *) dd->mutex );
5679 #else
5680     dd->mutex = NULL;
5681 #endif
5682
5683     return dd;
5684 }  /* end of opendir() */
5685 /*}}}*/
5686
5687 /*
5688  *  Set the flag to indicate we want versions or not.
5689  */
5690 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
5691 void
5692 vmsreaddirversions(DIR *dd, int flag)
5693 {
5694     dd->vms_wantversions = flag;
5695 }
5696 /*}}}*/
5697
5698 /*
5699  *  Free up an opened directory.
5700  */
5701 /*{{{ void closedir(DIR *dd)*/
5702 void
5703 closedir(DIR *dd)
5704 {
5705     int sts;
5706
5707     sts = lib$find_file_end(&dd->context);
5708     Safefree(dd->pattern);
5709 #if defined(USE_ITHREADS)
5710     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
5711     Safefree(dd->mutex);
5712 #endif
5713     Safefree(dd);
5714 }
5715 /*}}}*/
5716
5717 /*
5718  *  Collect all the version numbers for the current file.
5719  */
5720 static void
5721 collectversions(pTHX_ DIR *dd)
5722 {
5723     struct dsc$descriptor_s     pat;
5724     struct dsc$descriptor_s     res;
5725     struct dirent *e;
5726     char *p, *text, buff[sizeof dd->entry.d_name];
5727     int i;
5728     unsigned long context, tmpsts;
5729
5730     /* Convenient shorthand. */
5731     e = &dd->entry;
5732
5733     /* Add the version wildcard, ignoring the "*.*" put on before */
5734     i = strlen(dd->pattern);
5735     Newx(text,i + e->d_namlen + 3,char);
5736     strcpy(text, dd->pattern);
5737     sprintf(&text[i - 3], "%s;*", e->d_name);
5738
5739     /* Set up the pattern descriptor. */
5740     pat.dsc$a_pointer = text;
5741     pat.dsc$w_length = i + e->d_namlen - 1;
5742     pat.dsc$b_dtype = DSC$K_DTYPE_T;
5743     pat.dsc$b_class = DSC$K_CLASS_S;
5744
5745     /* Set up result descriptor. */
5746     res.dsc$a_pointer = buff;
5747     res.dsc$w_length = sizeof buff - 2;
5748     res.dsc$b_dtype = DSC$K_DTYPE_T;
5749     res.dsc$b_class = DSC$K_CLASS_S;
5750
5751     /* Read files, collecting versions. */
5752     for (context = 0, e->vms_verscount = 0;
5753          e->vms_verscount < VERSIZE(e);
5754          e->vms_verscount++) {
5755         tmpsts = lib$find_file(&pat, &res, &context);
5756         if (tmpsts == RMS$_NMF || context == 0) break;
5757         _ckvmssts(tmpsts);
5758         buff[sizeof buff - 1] = '\0';
5759         if ((p = strchr(buff, ';')))
5760             e->vms_versions[e->vms_verscount] = atoi(p + 1);
5761         else
5762             e->vms_versions[e->vms_verscount] = -1;
5763     }
5764
5765     _ckvmssts(lib$find_file_end(&context));
5766     Safefree(text);
5767
5768 }  /* end of collectversions() */
5769
5770 /*
5771  *  Read the next entry from the directory.
5772  */
5773 /*{{{ struct dirent *readdir(DIR *dd)*/
5774 struct dirent *
5775 Perl_readdir(pTHX_ DIR *dd)
5776 {
5777     struct dsc$descriptor_s     res;
5778     char *p, buff[sizeof dd->entry.d_name];
5779     unsigned long int tmpsts;
5780
5781     /* Set up result descriptor, and get next file. */
5782     res.dsc$a_pointer = buff;
5783     res.dsc$w_length = sizeof buff - 2;
5784     res.dsc$b_dtype = DSC$K_DTYPE_T;
5785     res.dsc$b_class = DSC$K_CLASS_S;
5786     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5787     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
5788     if (!(tmpsts & 1)) {
5789       set_vaxc_errno(tmpsts);
5790       switch (tmpsts) {
5791         case RMS$_PRV:
5792           set_errno(EACCES); break;
5793         case RMS$_DEV:
5794           set_errno(ENODEV); break;
5795         case RMS$_DIR:
5796           set_errno(ENOTDIR); break;
5797         case RMS$_FNF: case RMS$_DNF:
5798           set_errno(ENOENT); break;
5799         default:
5800           set_errno(EVMSERR);
5801       }
5802       return NULL;
5803     }
5804     dd->count++;
5805     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5806     if (!decc_efs_case_preserve) {
5807       buff[sizeof buff - 1] = '\0';
5808       for (p = buff; *p; p++) *p = _tolower(*p);
5809       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5810       *p = '\0';
5811     }
5812     else {
5813       /* we don't want to force to lowercase, just null terminate */
5814       buff[res.dsc$w_length] = '\0';
5815     }
5816     for (p = buff; *p; p++) *p = _tolower(*p);
5817     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
5818     *p = '\0';
5819
5820     /* Skip any directory component and just copy the name. */
5821     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
5822     else strcpy(dd->entry.d_name, buff);
5823
5824     /* Clobber the version. */
5825     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5826
5827     dd->entry.d_namlen = strlen(dd->entry.d_name);
5828     dd->entry.vms_verscount = 0;
5829     if (dd->vms_wantversions) collectversions(aTHX_ dd);
5830     return &dd->entry;
5831
5832 }  /* end of readdir() */
5833 /*}}}*/
5834
5835 /*
5836  *  Read the next entry from the directory -- thread-safe version.
5837  */
5838 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5839 int
5840 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5841 {
5842     int retval;
5843
5844     MUTEX_LOCK( (perl_mutex *) dd->mutex );
5845
5846     entry = readdir(dd);
5847     *result = entry;
5848     retval = ( *result == NULL ? errno : 0 );
5849
5850     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5851
5852     return retval;
5853
5854 }  /* end of readdir_r() */
5855 /*}}}*/
5856
5857 /*
5858  *  Return something that can be used in a seekdir later.
5859  */
5860 /*{{{ long telldir(DIR *dd)*/
5861 long
5862 telldir(DIR *dd)
5863 {
5864     return dd->count;
5865 }
5866 /*}}}*/
5867
5868 /*
5869  *  Return to a spot where we used to be.  Brute force.
5870  */
5871 /*{{{ void seekdir(DIR *dd,long count)*/
5872 void
5873 Perl_seekdir(pTHX_ DIR *dd, long count)
5874 {
5875     int vms_wantversions;
5876
5877     /* If we haven't done anything yet... */
5878     if (dd->count == 0)
5879         return;
5880
5881     /* Remember some state, and clear it. */
5882     vms_wantversions = dd->vms_wantversions;
5883     dd->vms_wantversions = 0;
5884     _ckvmssts(lib$find_file_end(&dd->context));
5885     dd->context = 0;
5886
5887     /* The increment is in readdir(). */
5888     for (dd->count = 0; dd->count < count; )
5889         readdir(dd);
5890
5891     dd->vms_wantversions = vms_wantversions;
5892
5893 }  /* end of seekdir() */
5894 /*}}}*/
5895
5896 /* VMS subprocess management
5897  *
5898  * my_vfork() - just a vfork(), after setting a flag to record that
5899  * the current script is trying a Unix-style fork/exec.
5900  *
5901  * vms_do_aexec() and vms_do_exec() are called in response to the
5902  * perl 'exec' function.  If this follows a vfork call, then they
5903  * call out the regular perl routines in doio.c which do an
5904  * execvp (for those who really want to try this under VMS).
5905  * Otherwise, they do exactly what the perl docs say exec should
5906  * do - terminate the current script and invoke a new command
5907  * (See below for notes on command syntax.)
5908  *
5909  * do_aspawn() and do_spawn() implement the VMS side of the perl
5910  * 'system' function.
5911  *
5912  * Note on command arguments to perl 'exec' and 'system': When handled
5913  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5914  * are concatenated to form a DCL command string.  If the first arg
5915  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5916  * the command string is handed off to DCL directly.  Otherwise,
5917  * the first token of the command is taken as the filespec of an image
5918  * to run.  The filespec is expanded using a default type of '.EXE' and
5919  * the process defaults for device, directory, etc., and if found, the resultant
5920  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5921  * the command string as parameters.  This is perhaps a bit complicated,
5922  * but I hope it will form a happy medium between what VMS folks expect
5923  * from lib$spawn and what Unix folks expect from exec.
5924  */
5925
5926 static int vfork_called;
5927
5928 /*{{{int my_vfork()*/
5929 int
5930 my_vfork()
5931 {
5932   vfork_called++;
5933   return vfork();
5934 }
5935 /*}}}*/
5936
5937
5938 static void
5939 vms_execfree(struct dsc$descriptor_s *vmscmd)
5940 {
5941   if (vmscmd) {
5942       if (vmscmd->dsc$a_pointer) {
5943           Safefree(vmscmd->dsc$a_pointer);
5944       }
5945       Safefree(vmscmd);
5946   }
5947 }
5948
5949 static char *
5950 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5951 {
5952   char *junk, *tmps = Nullch;
5953   register size_t cmdlen = 0;
5954   size_t rlen;
5955   register SV **idx;
5956   STRLEN n_a;
5957
5958   idx = mark;
5959   if (really) {
5960     tmps = SvPV(really,rlen);
5961     if (*tmps) {
5962       cmdlen += rlen + 1;
5963       idx++;
5964     }
5965   }
5966
5967   for (idx++; idx <= sp; idx++) {
5968     if (*idx) {
5969       junk = SvPVx(*idx,rlen);
5970       cmdlen += rlen ? rlen + 1 : 0;
5971     }
5972   }
5973   Newx(PL_Cmd,cmdlen+1,char);
5974
5975   if (tmps && *tmps) {
5976     strcpy(PL_Cmd,tmps);
5977     mark++;
5978   }
5979   else *PL_Cmd = '\0';
5980   while (++mark <= sp) {
5981     if (*mark) {
5982       char *s = SvPVx(*mark,n_a);
5983       if (!*s) continue;
5984       if (*PL_Cmd) strcat(PL_Cmd," ");
5985       strcat(PL_Cmd,s);
5986     }
5987   }
5988   return PL_Cmd;
5989
5990 }  /* end of setup_argstr() */
5991
5992
5993 static unsigned long int
5994 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
5995                    struct dsc$descriptor_s **pvmscmd)
5996 {
5997   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5998   $DESCRIPTOR(defdsc,".EXE");
5999   $DESCRIPTOR(defdsc2,".");
6000   $DESCRIPTOR(resdsc,resspec);
6001   struct dsc$descriptor_s *vmscmd;
6002   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6003   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
6004   register char *s, *rest, *cp, *wordbreak;
6005   char * cmd;
6006   int cmdlen;
6007   register int isdcl;
6008
6009   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
6010
6011   /* Make a copy for modification */
6012   cmdlen = strlen(incmd);
6013   Newx(cmd, cmdlen+1, char);
6014   strncpy(cmd, incmd, cmdlen);
6015   cmd[cmdlen] = 0;
6016
6017   vmscmd->dsc$a_pointer = NULL;
6018   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
6019   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
6020   vmscmd->dsc$w_length = 0;
6021   if (pvmscmd) *pvmscmd = vmscmd;
6022
6023   if (suggest_quote) *suggest_quote = 0;
6024
6025   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
6026     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
6027     Safefree(cmd);
6028   }
6029
6030   s = cmd;
6031
6032   while (*s && isspace(*s)) s++;
6033
6034   if (*s == '@' || *s == '$') {
6035     vmsspec[0] = *s;  rest = s + 1;
6036     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
6037   }
6038   else { cp = vmsspec; rest = s; }
6039   if (*rest == '.' || *rest == '/') {
6040     char *cp2;
6041     for (cp2 = resspec;
6042          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
6043          rest++, cp2++) *cp2 = *rest;
6044     *cp2 = '\0';
6045     if (do_tovmsspec(resspec,cp,0)) {
6046       s = vmsspec;
6047       if (*rest) {
6048         for (cp2 = vmsspec + strlen(vmsspec);
6049              *rest && cp2 - vmsspec < sizeof vmsspec;
6050              rest++, cp2++) *cp2 = *rest;
6051         *cp2 = '\0';
6052       }
6053     }
6054   }
6055   /* Intuit whether verb (first word of cmd) is a DCL command:
6056    *   - if first nonspace char is '@', it's a DCL indirection
6057    * otherwise
6058    *   - if verb contains a filespec separator, it's not a DCL command
6059    *   - if it doesn't, caller tells us whether to default to a DCL
6060    *     command, or to a local image unless told it's DCL (by leading '$')
6061    */
6062   if (*s == '@') {
6063       isdcl = 1;
6064       if (suggest_quote) *suggest_quote = 1;
6065   } else {
6066     register char *filespec = strpbrk(s,":<[.;");
6067     rest = wordbreak = strpbrk(s," \"\t/");
6068     if (!wordbreak) wordbreak = s + strlen(s);
6069     if (*s == '$') check_img = 0;
6070     if (filespec && (filespec < wordbreak)) isdcl = 0;
6071     else isdcl = !check_img;
6072   }
6073
6074   if (!isdcl) {
6075     imgdsc.dsc$a_pointer = s;
6076     imgdsc.dsc$w_length = wordbreak - s;
6077     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6078     if (!(retsts&1)) {
6079         _ckvmssts(lib$find_file_end(&cxt));
6080         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6081     if (!(retsts & 1) && *s == '$') {
6082           _ckvmssts(lib$find_file_end(&cxt));
6083       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
6084       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6085           if (!(retsts&1)) {
6086       _ckvmssts(lib$find_file_end(&cxt));
6087             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6088           }
6089     }
6090     }
6091     _ckvmssts(lib$find_file_end(&cxt));
6092
6093     if (retsts & 1) {
6094       FILE *fp;
6095       s = resspec;
6096       while (*s && !isspace(*s)) s++;
6097       *s = '\0';
6098
6099       /* check that it's really not DCL with no file extension */
6100       fp = fopen(resspec,"r","ctx=bin","shr=get");
6101       if (fp) {
6102         char b[4] = {0,0,0,0};
6103         read(fileno(fp),b,4);
6104         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
6105         fclose(fp);
6106       }
6107       if (check_img && isdcl) return RMS$_FNF;
6108
6109       if (cando_by_name(S_IXUSR,0,resspec)) {
6110         Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
6111         if (!isdcl) {
6112             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
6113             if (suggest_quote) *suggest_quote = 1;
6114         } else {
6115             strcpy(vmscmd->dsc$a_pointer,"@");
6116             if (suggest_quote) *suggest_quote = 1;
6117         }
6118         strcat(vmscmd->dsc$a_pointer,resspec);
6119         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
6120         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
6121         Safefree(cmd);
6122         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6123       }
6124       else retsts = RMS$_PRV;
6125     }
6126   }
6127   /* It's either a DCL command or we couldn't find a suitable image */
6128   vmscmd->dsc$w_length = strlen(cmd);
6129 /*  if (cmd == PL_Cmd) {
6130       vmscmd->dsc$a_pointer = PL_Cmd;
6131       if (suggest_quote) *suggest_quote = 1;
6132   }
6133   else  */
6134       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
6135
6136   Safefree(cmd);
6137
6138   /* check if it's a symbol (for quoting purposes) */
6139   if (suggest_quote && !*suggest_quote) {
6140     int iss;
6141     char equiv[LNM$C_NAMLENGTH];
6142     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6143     eqvdsc.dsc$a_pointer = equiv;
6144
6145     iss = lib$get_symbol(vmscmd,&eqvdsc);
6146     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
6147   }
6148   if (!(retsts & 1)) {
6149     /* just hand off status values likely to be due to user error */
6150     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
6151         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
6152        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
6153     else { _ckvmssts(retsts); }
6154   }
6155
6156   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6157
6158 }  /* end of setup_cmddsc() */
6159
6160
6161 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
6162 bool
6163 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
6164 {
6165   if (sp > mark) {
6166     if (vfork_called) {           /* this follows a vfork - act Unixish */
6167       vfork_called--;
6168       if (vfork_called < 0) {
6169         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6170         vfork_called = 0;
6171       }
6172       else return do_aexec(really,mark,sp);
6173     }
6174                                            /* no vfork - act VMSish */
6175     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
6176
6177   }
6178
6179   return FALSE;
6180 }  /* end of vms_do_aexec() */
6181 /*}}}*/
6182
6183 /* {{{bool vms_do_exec(char *cmd) */
6184 bool
6185 Perl_vms_do_exec(pTHX_ const char *cmd)
6186 {
6187   struct dsc$descriptor_s *vmscmd;
6188
6189   if (vfork_called) {             /* this follows a vfork - act Unixish */
6190     vfork_called--;
6191     if (vfork_called < 0) {
6192       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6193       vfork_called = 0;
6194     }
6195     else return do_exec(cmd);
6196   }
6197
6198   {                               /* no vfork - act VMSish */
6199     unsigned long int retsts;
6200
6201     TAINT_ENV();
6202     TAINT_PROPER("exec");
6203     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
6204       retsts = lib$do_command(vmscmd);
6205
6206     switch (retsts) {
6207       case RMS$_FNF: case RMS$_DNF:
6208         set_errno(ENOENT); break;
6209       case RMS$_DIR:
6210         set_errno(ENOTDIR); break;
6211       case RMS$_DEV:
6212         set_errno(ENODEV); break;
6213       case RMS$_PRV:
6214         set_errno(EACCES); break;
6215       case RMS$_SYN:
6216         set_errno(EINVAL); break;
6217       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6218         set_errno(E2BIG); break;
6219       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6220         _ckvmssts(retsts); /* fall through */
6221       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6222         set_errno(EVMSERR);
6223     }
6224     set_vaxc_errno(retsts);
6225     if (ckWARN(WARN_EXEC)) {
6226       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
6227              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
6228     }
6229     vms_execfree(vmscmd);
6230   }
6231
6232   return FALSE;
6233
6234 }  /* end of vms_do_exec() */
6235 /*}}}*/
6236
6237 unsigned long int Perl_do_spawn(pTHX_ const char *);
6238
6239 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
6240 unsigned long int
6241 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
6242 {
6243   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
6244
6245   return SS$_ABORT;
6246 }  /* end of do_aspawn() */
6247 /*}}}*/
6248
6249 /* {{{unsigned long int do_spawn(char *cmd) */
6250 unsigned long int
6251 Perl_do_spawn(pTHX_ const char *cmd)
6252 {
6253   unsigned long int sts, substs;
6254
6255   TAINT_ENV();
6256   TAINT_PROPER("spawn");
6257   if (!cmd || !*cmd) {
6258     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
6259     if (!(sts & 1)) {
6260       switch (sts) {
6261         case RMS$_FNF:  case RMS$_DNF:
6262           set_errno(ENOENT); break;
6263         case RMS$_DIR:
6264           set_errno(ENOTDIR); break;
6265         case RMS$_DEV:
6266           set_errno(ENODEV); break;
6267         case RMS$_PRV:
6268           set_errno(EACCES); break;
6269         case RMS$_SYN:
6270           set_errno(EINVAL); break;
6271         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6272           set_errno(E2BIG); break;
6273         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6274           _ckvmssts(sts); /* fall through */
6275         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6276           set_errno(EVMSERR);
6277       }
6278       set_vaxc_errno(sts);
6279       if (ckWARN(WARN_EXEC)) {
6280         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
6281                     Strerror(errno));
6282       }
6283     }
6284     sts = substs;
6285   }
6286   else {
6287     PerlIO * fp;
6288     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
6289     if (fp != NULL)
6290       my_pclose(fp);
6291   }
6292   return sts;
6293 }  /* end of do_spawn() */
6294 /*}}}*/
6295
6296
6297 static unsigned int *sockflags, sockflagsize;
6298
6299 /*
6300  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
6301  * routines found in some versions of the CRTL can't deal with sockets.
6302  * We don't shim the other file open routines since a socket isn't
6303  * likely to be opened by a name.
6304  */
6305 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
6306 FILE *my_fdopen(int fd, const char *mode)
6307 {
6308   FILE *fp = fdopen(fd, mode);
6309
6310   if (fp) {
6311     unsigned int fdoff = fd / sizeof(unsigned int);
6312     struct stat sbuf; /* native stat; we don't need flex_stat */
6313     if (!sockflagsize || fdoff > sockflagsize) {
6314       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
6315       else           Newx  (sockflags,fdoff+2,unsigned int);
6316       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
6317       sockflagsize = fdoff + 2;
6318     }
6319     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
6320       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
6321   }
6322   return fp;
6323
6324 }
6325 /*}}}*/
6326
6327
6328 /*
6329  * Clear the corresponding bit when the (possibly) socket stream is closed.
6330  * There still a small hole: we miss an implicit close which might occur
6331  * via freopen().  >> Todo
6332  */
6333 /*{{{ int my_fclose(FILE *fp)*/
6334 int my_fclose(FILE *fp) {
6335   if (fp) {
6336     unsigned int fd = fileno(fp);
6337     unsigned int fdoff = fd / sizeof(unsigned int);
6338
6339     if (sockflagsize && fdoff <= sockflagsize)
6340       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
6341   }
6342   return fclose(fp);
6343 }
6344 /*}}}*/
6345
6346
6347 /*
6348  * A simple fwrite replacement which outputs itmsz*nitm chars without
6349  * introducing record boundaries every itmsz chars.
6350  * We are using fputs, which depends on a terminating null.  We may
6351  * well be writing binary data, so we need to accommodate not only
6352  * data with nulls sprinkled in the middle but also data with no null
6353  * byte at the end.
6354  */
6355 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
6356 int
6357 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
6358 {
6359   register char *cp, *end, *cpd, *data;
6360   register unsigned int fd = fileno(dest);
6361   register unsigned int fdoff = fd / sizeof(unsigned int);
6362   int retval;
6363   int bufsize = itmsz * nitm + 1;
6364
6365   if (fdoff < sockflagsize &&
6366       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
6367     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
6368     return nitm;
6369   }
6370
6371   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
6372   memcpy( data, src, itmsz*nitm );
6373   data[itmsz*nitm] = '\0';
6374
6375   end = data + itmsz * nitm;
6376   retval = (int) nitm; /* on success return # items written */
6377
6378   cpd = data;
6379   while (cpd <= end) {
6380     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
6381     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
6382     if (cp < end)
6383       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
6384     cpd = cp + 1;
6385   }
6386
6387   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
6388   return retval;
6389
6390 }  /* end of my_fwrite() */
6391 /*}}}*/
6392
6393 /*{{{ int my_flush(FILE *fp)*/
6394 int
6395 Perl_my_flush(pTHX_ FILE *fp)
6396 {
6397     int res;
6398     if ((res = fflush(fp)) == 0 && fp) {
6399 #ifdef VMS_DO_SOCKETS
6400         Stat_t s;
6401         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
6402 #endif
6403             res = fsync(fileno(fp));
6404     }
6405 /*
6406  * If the flush succeeded but set end-of-file, we need to clear
6407  * the error because our caller may check ferror().  BTW, this
6408  * probably means we just flushed an empty file.
6409  */
6410     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
6411
6412     return res;
6413 }
6414 /*}}}*/
6415
6416 /*
6417  * Here are replacements for the following Unix routines in the VMS environment:
6418  *      getpwuid    Get information for a particular UIC or UID
6419  *      getpwnam    Get information for a named user
6420  *      getpwent    Get information for each user in the rights database
6421  *      setpwent    Reset search to the start of the rights database
6422  *      endpwent    Finish searching for users in the rights database
6423  *
6424  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
6425  * (defined in pwd.h), which contains the following fields:-
6426  *      struct passwd {
6427  *              char        *pw_name;    Username (in lower case)
6428  *              char        *pw_passwd;  Hashed password
6429  *              unsigned int pw_uid;     UIC
6430  *              unsigned int pw_gid;     UIC group  number
6431  *              char        *pw_unixdir; Default device/directory (VMS-style)
6432  *              char        *pw_gecos;   Owner name
6433  *              char        *pw_dir;     Default device/directory (Unix-style)
6434  *              char        *pw_shell;   Default CLI name (eg. DCL)
6435  *      };
6436  * If the specified user does not exist, getpwuid and getpwnam return NULL.
6437  *
6438  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
6439  * not the UIC member number (eg. what's returned by getuid()),
6440  * getpwuid() can accept either as input (if uid is specified, the caller's
6441  * UIC group is used), though it won't recognise gid=0.
6442  *
6443  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
6444  * information about other users in your group or in other groups, respectively.
6445  * If the required privilege is not available, then these routines fill only
6446  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
6447  * string).
6448  *
6449  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
6450  */
6451
6452 /* sizes of various UAF record fields */
6453 #define UAI$S_USERNAME 12
6454 #define UAI$S_IDENT    31
6455 #define UAI$S_OWNER    31
6456 #define UAI$S_DEFDEV   31
6457 #define UAI$S_DEFDIR   63
6458 #define UAI$S_DEFCLI   31
6459 #define UAI$S_PWD       8
6460
6461 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
6462                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
6463                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
6464
6465 static char __empty[]= "";
6466 static struct passwd __passwd_empty=
6467     {(char *) __empty, (char *) __empty, 0, 0,
6468      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
6469 static int contxt= 0;
6470 static struct passwd __pwdcache;
6471 static char __pw_namecache[UAI$S_IDENT+1];
6472
6473 /*
6474  * This routine does most of the work extracting the user information.
6475  */
6476 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
6477 {
6478     static struct {
6479         unsigned char length;
6480         char pw_gecos[UAI$S_OWNER+1];
6481     } owner;
6482     static union uicdef uic;
6483     static struct {
6484         unsigned char length;
6485         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
6486     } defdev;
6487     static struct {
6488         unsigned char length;
6489         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
6490     } defdir;
6491     static struct {
6492         unsigned char length;
6493         char pw_shell[UAI$S_DEFCLI+1];
6494     } defcli;
6495     static char pw_passwd[UAI$S_PWD+1];
6496
6497     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
6498     struct dsc$descriptor_s name_desc;
6499     unsigned long int sts;
6500
6501     static struct itmlst_3 itmlst[]= {
6502         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
6503         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
6504         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
6505         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
6506         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
6507         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
6508         {0,                0,           NULL,    NULL}};
6509
6510     name_desc.dsc$w_length=  strlen(name);
6511     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
6512     name_desc.dsc$b_class=   DSC$K_CLASS_S;
6513     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
6514
6515 /*  Note that sys$getuai returns many fields as counted strings. */
6516     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
6517     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
6518       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
6519     }
6520     else { _ckvmssts(sts); }
6521     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
6522
6523     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
6524     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
6525     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
6526     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
6527     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
6528     owner.pw_gecos[lowner]=            '\0';
6529     defdev.pw_dir[ldefdev+ldefdir]= '\0';
6530     defcli.pw_shell[ldefcli]=          '\0';
6531     if (valid_uic(uic)) {
6532         pwd->pw_uid= uic.uic$l_uic;
6533         pwd->pw_gid= uic.uic$v_group;
6534     }
6535     else
6536       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
6537     pwd->pw_passwd=  pw_passwd;
6538     pwd->pw_gecos=   owner.pw_gecos;
6539     pwd->pw_dir=     defdev.pw_dir;
6540     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
6541     pwd->pw_shell=   defcli.pw_shell;
6542     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
6543         int ldir;
6544         ldir= strlen(pwd->pw_unixdir) - 1;
6545         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
6546     }
6547     else
6548         strcpy(pwd->pw_unixdir, pwd->pw_dir);
6549     if (!decc_efs_case_preserve)
6550         __mystrtolower(pwd->pw_unixdir);
6551     return 1;
6552 }
6553
6554 /*
6555  * Get information for a named user.
6556 */
6557 /*{{{struct passwd *getpwnam(char *name)*/
6558 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
6559 {
6560     struct dsc$descriptor_s name_desc;
6561     union uicdef uic;
6562     unsigned long int status, sts;
6563
6564     __pwdcache = __passwd_empty;
6565     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
6566       /* We still may be able to determine pw_uid and pw_gid */
6567       name_desc.dsc$w_length=  strlen(name);
6568       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
6569       name_desc.dsc$b_class=   DSC$K_CLASS_S;
6570       name_desc.dsc$a_pointer= (char *) name;
6571       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
6572         __pwdcache.pw_uid= uic.uic$l_uic;
6573         __pwdcache.pw_gid= uic.uic$v_group;
6574       }
6575       else {
6576         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
6577           set_vaxc_errno(sts);
6578           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
6579           return NULL;
6580         }
6581         else { _ckvmssts(sts); }
6582       }
6583     }
6584     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
6585     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
6586     __pwdcache.pw_name= __pw_namecache;
6587     return &__pwdcache;
6588 }  /* end of my_getpwnam() */
6589 /*}}}*/
6590
6591 /*
6592  * Get information for a particular UIC or UID.
6593  * Called by my_getpwent with uid=-1 to list all users.
6594 */
6595 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
6596 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
6597 {
6598     const $DESCRIPTOR(name_desc,__pw_namecache);
6599     unsigned short lname;
6600     union uicdef uic;
6601     unsigned long int status;
6602
6603     if (uid == (unsigned int) -1) {
6604       do {
6605         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
6606         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
6607           set_vaxc_errno(status);
6608           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6609           my_endpwent();
6610           return NULL;
6611         }
6612         else { _ckvmssts(status); }
6613       } while (!valid_uic (uic));
6614     }
6615     else {
6616       uic.uic$l_uic= uid;
6617       if (!uic.uic$v_group)
6618         uic.uic$v_group= PerlProc_getgid();
6619       if (valid_uic(uic))
6620         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
6621       else status = SS$_IVIDENT;
6622       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
6623           status == RMS$_PRV) {
6624         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6625         return NULL;
6626       }
6627       else { _ckvmssts(status); }
6628     }
6629     __pw_namecache[lname]= '\0';
6630     __mystrtolower(__pw_namecache);
6631
6632     __pwdcache = __passwd_empty;
6633     __pwdcache.pw_name = __pw_namecache;
6634
6635 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
6636     The identifier's value is usually the UIC, but it doesn't have to be,
6637     so if we can, we let fillpasswd update this. */
6638     __pwdcache.pw_uid =  uic.uic$l_uic;
6639     __pwdcache.pw_gid =  uic.uic$v_group;
6640
6641     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
6642     return &__pwdcache;
6643
6644 }  /* end of my_getpwuid() */
6645 /*}}}*/
6646
6647 /*
6648  * Get information for next user.
6649 */
6650 /*{{{struct passwd *my_getpwent()*/
6651 struct passwd *Perl_my_getpwent(pTHX)
6652 {
6653     return (my_getpwuid((unsigned int) -1));
6654 }
6655 /*}}}*/
6656
6657 /*
6658  * Finish searching rights database for users.
6659 */
6660 /*{{{void my_endpwent()*/
6661 void Perl_my_endpwent(pTHX)
6662 {
6663     if (contxt) {
6664       _ckvmssts(sys$finish_rdb(&contxt));
6665       contxt= 0;
6666     }
6667 }
6668 /*}}}*/
6669
6670 #ifdef HOMEGROWN_POSIX_SIGNALS
6671   /* Signal handling routines, pulled into the core from POSIX.xs.
6672    *
6673    * We need these for threads, so they've been rolled into the core,
6674    * rather than left in POSIX.xs.
6675    *
6676    * (DRS, Oct 23, 1997)
6677    */
6678
6679   /* sigset_t is atomic under VMS, so these routines are easy */
6680 /*{{{int my_sigemptyset(sigset_t *) */
6681 int my_sigemptyset(sigset_t *set) {
6682     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6683     *set = 0; return 0;
6684 }
6685 /*}}}*/
6686
6687
6688 /*{{{int my_sigfillset(sigset_t *)*/
6689 int my_sigfillset(sigset_t *set) {
6690     int i;
6691     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6692     for (i = 0; i < NSIG; i++) *set |= (1 << i);
6693     return 0;
6694 }
6695 /*}}}*/
6696
6697
6698 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
6699 int my_sigaddset(sigset_t *set, int sig) {
6700     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6701     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6702     *set |= (1 << (sig - 1));
6703     return 0;
6704 }
6705 /*}}}*/
6706
6707
6708 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
6709 int my_sigdelset(sigset_t *set, int sig) {
6710     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6711     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6712     *set &= ~(1 << (sig - 1));
6713     return 0;
6714 }
6715 /*}}}*/
6716
6717
6718 /*{{{int my_sigismember(sigset_t *set, int sig)*/
6719 int my_sigismember(sigset_t *set, int sig) {
6720     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6721     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6722     return *set & (1 << (sig - 1));
6723 }
6724 /*}}}*/
6725
6726
6727 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
6728 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
6729     sigset_t tempmask;
6730
6731     /* If set and oset are both null, then things are badly wrong. Bail out. */
6732     if ((oset == NULL) && (set == NULL)) {
6733       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
6734       return -1;
6735     }
6736
6737     /* If set's null, then we're just handling a fetch. */
6738     if (set == NULL) {
6739         tempmask = sigblock(0);
6740     }
6741     else {
6742       switch (how) {
6743       case SIG_SETMASK:
6744         tempmask = sigsetmask(*set);
6745         break;
6746       case SIG_BLOCK:
6747         tempmask = sigblock(*set);
6748         break;
6749       case SIG_UNBLOCK:
6750         tempmask = sigblock(0);
6751         sigsetmask(*oset & ~tempmask);
6752         break;
6753       default:
6754         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6755         return -1;
6756       }
6757     }
6758
6759     /* Did they pass us an oset? If so, stick our holding mask into it */
6760     if (oset)
6761       *oset = tempmask;
6762
6763     return 0;
6764 }
6765 /*}}}*/
6766 #endif  /* HOMEGROWN_POSIX_SIGNALS */
6767
6768
6769 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
6770  * my_utime(), and flex_stat(), all of which operate on UTC unless
6771  * VMSISH_TIMES is true.
6772  */
6773 /* method used to handle UTC conversions:
6774  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
6775  */
6776 static int gmtime_emulation_type;
6777 /* number of secs to add to UTC POSIX-style time to get local time */
6778 static long int utc_offset_secs;
6779
6780 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
6781  * in vmsish.h.  #undef them here so we can call the CRTL routines
6782  * directly.
6783  */
6784 #undef gmtime
6785 #undef localtime
6786 #undef time
6787
6788
6789 /*
6790  * DEC C previous to 6.0 corrupts the behavior of the /prefix
6791  * qualifier with the extern prefix pragma.  This provisional
6792  * hack circumvents this prefix pragma problem in previous
6793  * precompilers.
6794  */
6795 #if defined(__VMS_VER) && __VMS_VER >= 70000000
6796 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
6797 #    pragma __extern_prefix save
6798 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
6799 #    define gmtime decc$__utctz_gmtime
6800 #    define localtime decc$__utctz_localtime
6801 #    define time decc$__utc_time
6802 #    pragma __extern_prefix restore
6803
6804      struct tm *gmtime(), *localtime();
6805
6806 #  endif
6807 #endif
6808
6809
6810 static time_t toutc_dst(time_t loc) {
6811   struct tm *rsltmp;
6812
6813   if ((rsltmp = localtime(&loc)) == NULL) return -1;
6814   loc -= utc_offset_secs;
6815   if (rsltmp->tm_isdst) loc -= 3600;
6816   return loc;
6817 }
6818 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6819        ((gmtime_emulation_type || my_time(NULL)), \
6820        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6821        ((secs) - utc_offset_secs))))
6822
6823 static time_t toloc_dst(time_t utc) {
6824   struct tm *rsltmp;
6825
6826   utc += utc_offset_secs;
6827   if ((rsltmp = localtime(&utc)) == NULL) return -1;
6828   if (rsltmp->tm_isdst) utc += 3600;
6829   return utc;
6830 }
6831 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6832        ((gmtime_emulation_type || my_time(NULL)), \
6833        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6834        ((secs) + utc_offset_secs))))
6835
6836 #ifndef RTL_USES_UTC
6837 /*
6838
6839     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
6840         DST starts on 1st sun of april      at 02:00  std time
6841             ends on last sun of october     at 02:00  dst time
6842     see the UCX management command reference, SET CONFIG TIMEZONE
6843     for formatting info.
6844
6845     No, it's not as general as it should be, but then again, NOTHING
6846     will handle UK times in a sensible way.
6847 */
6848
6849
6850 /*
6851     parse the DST start/end info:
6852     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6853 */
6854
6855 static char *
6856 tz_parse_startend(char *s, struct tm *w, int *past)
6857 {
6858     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6859     int ly, dozjd, d, m, n, hour, min, sec, j, k;
6860     time_t g;
6861
6862     if (!s)    return 0;
6863     if (!w) return 0;
6864     if (!past) return 0;
6865
6866     ly = 0;
6867     if (w->tm_year % 4        == 0) ly = 1;
6868     if (w->tm_year % 100      == 0) ly = 0;
6869     if (w->tm_year+1900 % 400 == 0) ly = 1;
6870     if (ly) dinm[1]++;
6871
6872     dozjd = isdigit(*s);
6873     if (*s == 'J' || *s == 'j' || dozjd) {
6874         if (!dozjd && !isdigit(*++s)) return 0;
6875         d = *s++ - '0';
6876         if (isdigit(*s)) {
6877             d = d*10 + *s++ - '0';
6878             if (isdigit(*s)) {
6879                 d = d*10 + *s++ - '0';
6880             }
6881         }
6882         if (d == 0) return 0;
6883         if (d > 366) return 0;
6884         d--;
6885         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
6886         g = d * 86400;
6887         dozjd = 1;
6888     } else if (*s == 'M' || *s == 'm') {
6889         if (!isdigit(*++s)) return 0;
6890         m = *s++ - '0';
6891         if (isdigit(*s)) m = 10*m + *s++ - '0';
6892         if (*s != '.') return 0;
6893         if (!isdigit(*++s)) return 0;
6894         n = *s++ - '0';
6895         if (n < 1 || n > 5) return 0;
6896         if (*s != '.') return 0;
6897         if (!isdigit(*++s)) return 0;
6898         d = *s++ - '0';
6899         if (d > 6) return 0;
6900     }
6901
6902     if (*s == '/') {
6903         if (!isdigit(*++s)) return 0;
6904         hour = *s++ - '0';
6905         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6906         if (*s == ':') {
6907             if (!isdigit(*++s)) return 0;
6908             min = *s++ - '0';
6909             if (isdigit(*s)) min = 10*min + *s++ - '0';
6910             if (*s == ':') {
6911                 if (!isdigit(*++s)) return 0;
6912                 sec = *s++ - '0';
6913                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6914             }
6915         }
6916     } else {
6917         hour = 2;
6918         min = 0;
6919         sec = 0;
6920     }
6921
6922     if (dozjd) {
6923         if (w->tm_yday < d) goto before;
6924         if (w->tm_yday > d) goto after;
6925     } else {
6926         if (w->tm_mon+1 < m) goto before;
6927         if (w->tm_mon+1 > m) goto after;
6928
6929         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
6930         k = d - j; /* mday of first d */
6931         if (k <= 0) k += 7;
6932         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
6933         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6934         if (w->tm_mday < k) goto before;
6935         if (w->tm_mday > k) goto after;
6936     }
6937
6938     if (w->tm_hour < hour) goto before;
6939     if (w->tm_hour > hour) goto after;
6940     if (w->tm_min  < min)  goto before;
6941     if (w->tm_min  > min)  goto after;
6942     if (w->tm_sec  < sec)  goto before;
6943     goto after;
6944
6945 before:
6946     *past = 0;
6947     return s;
6948 after:
6949     *past = 1;
6950     return s;
6951 }
6952
6953
6954
6955
6956 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
6957
6958 static char *
6959 tz_parse_offset(char *s, int *offset)
6960 {
6961     int hour = 0, min = 0, sec = 0;
6962     int neg = 0;
6963     if (!s) return 0;
6964     if (!offset) return 0;
6965
6966     if (*s == '-') {neg++; s++;}
6967     if (*s == '+') s++;
6968     if (!isdigit(*s)) return 0;
6969     hour = *s++ - '0';
6970     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6971     if (hour > 24) return 0;
6972     if (*s == ':') {
6973         if (!isdigit(*++s)) return 0;
6974         min = *s++ - '0';
6975         if (isdigit(*s)) min = min*10 + (*s++ - '0');
6976         if (min > 59) return 0;
6977         if (*s == ':') {
6978             if (!isdigit(*++s)) return 0;
6979             sec = *s++ - '0';
6980             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6981             if (sec > 59) return 0;
6982         }
6983     }
6984
6985     *offset = (hour*60+min)*60 + sec;
6986     if (neg) *offset = -*offset;
6987     return s;
6988 }
6989
6990 /*
6991     input time is w, whatever type of time the CRTL localtime() uses.
6992     sets dst, the zone, and the gmtoff (seconds)
6993
6994     caches the value of TZ and UCX$TZ env variables; note that
6995     my_setenv looks for these and sets a flag if they're changed
6996     for efficiency.
6997
6998     We have to watch out for the "australian" case (dst starts in
6999     october, ends in april)...flagged by "reverse" and checked by
7000     scanning through the months of the previous year.
7001
7002 */
7003
7004 static int
7005 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
7006 {
7007     time_t when;
7008     struct tm *w2;
7009     char *s,*s2;
7010     char *dstzone, *tz, *s_start, *s_end;
7011     int std_off, dst_off, isdst;
7012     int y, dststart, dstend;
7013     static char envtz[1025];  /* longer than any logical, symbol, ... */
7014     static char ucxtz[1025];
7015     static char reversed = 0;
7016
7017     if (!w) return 0;
7018
7019     if (tz_updated) {
7020         tz_updated = 0;
7021         reversed = -1;  /* flag need to check  */
7022         envtz[0] = ucxtz[0] = '\0';
7023         tz = my_getenv("TZ",0);
7024         if (tz) strcpy(envtz, tz);
7025         tz = my_getenv("UCX$TZ",0);
7026         if (tz) strcpy(ucxtz, tz);
7027         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
7028     }
7029     tz = envtz;
7030     if (!*tz) tz = ucxtz;
7031
7032     s = tz;
7033     while (isalpha(*s)) s++;
7034     s = tz_parse_offset(s, &std_off);
7035     if (!s) return 0;
7036     if (!*s) {                  /* no DST, hurray we're done! */
7037         isdst = 0;
7038         goto done;
7039     }
7040
7041     dstzone = s;
7042     while (isalpha(*s)) s++;
7043     s2 = tz_parse_offset(s, &dst_off);
7044     if (s2) {
7045         s = s2;
7046     } else {
7047         dst_off = std_off - 3600;
7048     }
7049
7050     if (!*s) {      /* default dst start/end?? */
7051         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
7052             s = strchr(ucxtz,',');
7053         }
7054         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
7055     }
7056     if (*s != ',') return 0;
7057
7058     when = *w;
7059     when = _toutc(when);      /* convert to utc */
7060     when = when - std_off;    /* convert to pseudolocal time*/
7061
7062     w2 = localtime(&when);
7063     y = w2->tm_year;
7064     s_start = s+1;
7065     s = tz_parse_startend(s_start,w2,&dststart);
7066     if (!s) return 0;
7067     if (*s != ',') return 0;
7068
7069     when = *w;
7070     when = _toutc(when);      /* convert to utc */
7071     when = when - dst_off;    /* convert to pseudolocal time*/
7072     w2 = localtime(&when);
7073     if (w2->tm_year != y) {   /* spans a year, just check one time */
7074         when += dst_off - std_off;
7075         w2 = localtime(&when);
7076     }
7077     s_end = s+1;
7078     s = tz_parse_startend(s_end,w2,&dstend);
7079     if (!s) return 0;
7080
7081     if (reversed == -1) {  /* need to check if start later than end */
7082         int j, ds, de;
7083
7084         when = *w;
7085         if (when < 2*365*86400) {
7086             when += 2*365*86400;
7087         } else {
7088             when -= 365*86400;
7089         }
7090         w2 =localtime(&when);
7091         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
7092
7093         for (j = 0; j < 12; j++) {
7094             w2 =localtime(&when);
7095             tz_parse_startend(s_start,w2,&ds);
7096             tz_parse_startend(s_end,w2,&de);
7097             if (ds != de) break;
7098             when += 30*86400;
7099         }
7100         reversed = 0;
7101         if (de && !ds) reversed = 1;
7102     }
7103
7104     isdst = dststart && !dstend;
7105     if (reversed) isdst = dststart  || !dstend;
7106
7107 done:
7108     if (dst)    *dst = isdst;
7109     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
7110     if (isdst)  tz = dstzone;
7111     if (zone) {
7112         while(isalpha(*tz))  *zone++ = *tz++;
7113         *zone = '\0';
7114     }
7115     return 1;
7116 }
7117
7118 #endif /* !RTL_USES_UTC */
7119
7120 /* my_time(), my_localtime(), my_gmtime()
7121  * By default traffic in UTC time values, using CRTL gmtime() or
7122  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
7123  * Note: We need to use these functions even when the CRTL has working
7124  * UTC support, since they also handle C<use vmsish qw(times);>
7125  *
7126  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
7127  * Modified by Charles Bailey <bailey@newman.upenn.edu>
7128  */
7129
7130 /*{{{time_t my_time(time_t *timep)*/
7131 time_t Perl_my_time(pTHX_ time_t *timep)
7132 {
7133   time_t when;
7134   struct tm *tm_p;
7135
7136   if (gmtime_emulation_type == 0) {
7137     int dstnow;
7138     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
7139                               /* results of calls to gmtime() and localtime() */
7140                               /* for same &base */
7141
7142     gmtime_emulation_type++;
7143     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
7144       char off[LNM$C_NAMLENGTH+1];;
7145
7146       gmtime_emulation_type++;
7147       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
7148         gmtime_emulation_type++;
7149         utc_offset_secs = 0;
7150         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
7151       }
7152       else { utc_offset_secs = atol(off); }
7153     }
7154     else { /* We've got a working gmtime() */
7155       struct tm gmt, local;
7156
7157       gmt = *tm_p;
7158       tm_p = localtime(&base);
7159       local = *tm_p;
7160       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
7161       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
7162       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
7163       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
7164     }
7165   }
7166
7167   when = time(NULL);
7168 # ifdef VMSISH_TIME
7169 # ifdef RTL_USES_UTC
7170   if (VMSISH_TIME) when = _toloc(when);
7171 # else
7172   if (!VMSISH_TIME) when = _toutc(when);
7173 # endif
7174 # endif
7175   if (timep != NULL) *timep = when;
7176   return when;
7177
7178 }  /* end of my_time() */
7179 /*}}}*/
7180
7181
7182 /*{{{struct tm *my_gmtime(const time_t *timep)*/
7183 struct tm *
7184 Perl_my_gmtime(pTHX_ const time_t *timep)
7185 {
7186   char *p;
7187   time_t when;
7188   struct tm *rsltmp;
7189
7190   if (timep == NULL) {
7191     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7192     return NULL;
7193   }
7194   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
7195
7196   when = *timep;
7197 # ifdef VMSISH_TIME
7198   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
7199 #  endif
7200 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
7201   return gmtime(&when);
7202 # else
7203   /* CRTL localtime() wants local time as input, so does no tz correction */
7204   rsltmp = localtime(&when);
7205   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
7206   return rsltmp;
7207 #endif
7208 }  /* end of my_gmtime() */
7209 /*}}}*/
7210
7211
7212 /*{{{struct tm *my_localtime(const time_t *timep)*/
7213 struct tm *
7214 Perl_my_localtime(pTHX_ const time_t *timep)
7215 {
7216   time_t when, whenutc;
7217   struct tm *rsltmp;
7218   int dst, offset;
7219
7220   if (timep == NULL) {
7221     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7222     return NULL;
7223   }
7224   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
7225   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
7226
7227   when = *timep;
7228 # ifdef RTL_USES_UTC
7229 # ifdef VMSISH_TIME
7230   if (VMSISH_TIME) when = _toutc(when);
7231 # endif
7232   /* CRTL localtime() wants UTC as input, does tz correction itself */
7233   return localtime(&when);
7234
7235 # else /* !RTL_USES_UTC */
7236   whenutc = when;
7237 # ifdef VMSISH_TIME
7238   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
7239   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
7240 # endif
7241   dst = -1;
7242 #ifndef RTL_USES_UTC
7243   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
7244       when = whenutc - offset;                   /* pseudolocal time*/
7245   }
7246 # endif
7247   /* CRTL localtime() wants local time as input, so does no tz correction */
7248   rsltmp = localtime(&when);
7249   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
7250   return rsltmp;
7251 # endif
7252
7253 } /*  end of my_localtime() */
7254 /*}}}*/
7255
7256 /* Reset definitions for later calls */
7257 #define gmtime(t)    my_gmtime(t)
7258 #define localtime(t) my_localtime(t)
7259 #define time(t)      my_time(t)
7260
7261
7262 /* my_utime - update modification time of a file
7263  * calling sequence is identical to POSIX utime(), but under
7264  * VMS only the modification time is changed; ODS-2 does not
7265  * maintain access times.  Restrictions differ from the POSIX
7266  * definition in that the time can be changed as long as the
7267  * caller has permission to execute the necessary IO$_MODIFY $QIO;
7268  * no separate checks are made to insure that the caller is the
7269  * owner of the file or has special privs enabled.
7270  * Code here is based on Joe Meadows' FILE utility.
7271  */
7272
7273 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
7274  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
7275  * in 100 ns intervals.
7276  */
7277 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
7278
7279 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
7280 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
7281 {
7282   register int i;
7283   int sts;
7284   long int bintime[2], len = 2, lowbit, unixtime,
7285            secscale = 10000000; /* seconds --> 100 ns intervals */
7286   unsigned long int chan, iosb[2], retsts;
7287   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
7288   struct FAB myfab = cc$rms_fab;
7289   struct NAM mynam = cc$rms_nam;
7290 #if defined (__DECC) && defined (__VAX)
7291   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
7292    * at least through VMS V6.1, which causes a type-conversion warning.
7293    */
7294 #  pragma message save
7295 #  pragma message disable cvtdiftypes
7296 #endif
7297   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
7298   struct fibdef myfib;
7299 #if defined (__DECC) && defined (__VAX)
7300   /* This should be right after the declaration of myatr, but due
7301    * to a bug in VAX DEC C, this takes effect a statement early.
7302    */
7303 #  pragma message restore
7304 #endif
7305   /* cast ok for read only parameter */
7306   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
7307                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
7308                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
7309
7310   if (file == NULL || *file == '\0') {
7311     set_errno(ENOENT);
7312     set_vaxc_errno(LIB$_INVARG);
7313     return -1;
7314   }
7315   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
7316
7317   if (utimes != NULL) {
7318     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
7319      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
7320      * Since time_t is unsigned long int, and lib$emul takes a signed long int
7321      * as input, we force the sign bit to be clear by shifting unixtime right
7322      * one bit, then multiplying by an extra factor of 2 in lib$emul().
7323      */
7324     lowbit = (utimes->modtime & 1) ? secscale : 0;
7325     unixtime = (long int) utimes->modtime;
7326 #   ifdef VMSISH_TIME
7327     /* If input was UTC; convert to local for sys svc */
7328     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
7329 #   endif
7330     unixtime >>= 1;  secscale <<= 1;
7331     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
7332     if (!(retsts & 1)) {
7333       set_errno(EVMSERR);
7334       set_vaxc_errno(retsts);
7335       return -1;
7336     }
7337     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
7338     if (!(retsts & 1)) {
7339       set_errno(EVMSERR);
7340       set_vaxc_errno(retsts);
7341       return -1;
7342     }
7343   }
7344   else {
7345     /* Just get the current time in VMS format directly */
7346     retsts = sys$gettim(bintime);
7347     if (!(retsts & 1)) {
7348       set_errno(EVMSERR);
7349       set_vaxc_errno(retsts);
7350       return -1;
7351     }
7352   }
7353
7354   myfab.fab$l_fna = vmsspec;
7355   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
7356   myfab.fab$l_nam = &mynam;
7357   mynam.nam$l_esa = esa;
7358   mynam.nam$b_ess = (unsigned char) sizeof esa;
7359   mynam.nam$l_rsa = rsa;
7360   mynam.nam$b_rss = (unsigned char) sizeof rsa;
7361   if (decc_efs_case_preserve)
7362       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7363
7364   /* Look for the file to be affected, letting RMS parse the file
7365    * specification for us as well.  I have set errno using only
7366    * values documented in the utime() man page for VMS POSIX.
7367    */
7368   retsts = sys$parse(&myfab,0,0);
7369   if (!(retsts & 1)) {
7370     set_vaxc_errno(retsts);
7371     if      (retsts == RMS$_PRV) set_errno(EACCES);
7372     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
7373     else                         set_errno(EVMSERR);
7374     return -1;
7375   }
7376   retsts = sys$search(&myfab,0,0);
7377   if (!(retsts & 1)) {
7378     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7379     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7380     set_vaxc_errno(retsts);
7381     if      (retsts == RMS$_PRV) set_errno(EACCES);
7382     else if (retsts == RMS$_FNF) set_errno(ENOENT);
7383     else                         set_errno(EVMSERR);
7384     return -1;
7385   }
7386
7387   devdsc.dsc$w_length = mynam.nam$b_dev;
7388   /* cast ok for read only parameter */
7389   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
7390
7391   retsts = sys$assign(&devdsc,&chan,0,0);
7392   if (!(retsts & 1)) {
7393     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7394     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7395     set_vaxc_errno(retsts);
7396     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
7397     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
7398     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
7399     else                               set_errno(EVMSERR);
7400     return -1;
7401   }
7402
7403   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
7404   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
7405
7406   memset((void *) &myfib, 0, sizeof myfib);
7407 #if defined(__DECC) || defined(__DECCXX)
7408   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
7409   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
7410   /* This prevents the revision time of the file being reset to the current
7411    * time as a result of our IO$_MODIFY $QIO. */
7412   myfib.fib$l_acctl = FIB$M_NORECORD;
7413 #else
7414   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
7415   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
7416   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
7417 #endif
7418   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
7419   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7420   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7421   _ckvmssts(sys$dassgn(chan));
7422   if (retsts & 1) retsts = iosb[0];
7423   if (!(retsts & 1)) {
7424     set_vaxc_errno(retsts);
7425     if (retsts == SS$_NOPRIV) set_errno(EACCES);
7426     else                      set_errno(EVMSERR);
7427     return -1;
7428   }
7429
7430   return 0;
7431 }  /* end of my_utime() */
7432 /*}}}*/
7433
7434 /*
7435  * flex_stat, flex_fstat
7436  * basic stat, but gets it right when asked to stat
7437  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
7438  */
7439
7440 /* encode_dev packs a VMS device name string into an integer to allow
7441  * simple comparisons. This can be used, for example, to check whether two
7442  * files are located on the same device, by comparing their encoded device
7443  * names. Even a string comparison would not do, because stat() reuses the
7444  * device name buffer for each call; so without encode_dev, it would be
7445  * necessary to save the buffer and use strcmp (this would mean a number of
7446  * changes to the standard Perl code, to say nothing of what a Perl script
7447  * would have to do.
7448  *
7449  * The device lock id, if it exists, should be unique (unless perhaps compared
7450  * with lock ids transferred from other nodes). We have a lock id if the disk is
7451  * mounted cluster-wide, which is when we tend to get long (host-qualified)
7452  * device names. Thus we use the lock id in preference, and only if that isn't
7453  * available, do we try to pack the device name into an integer (flagged by
7454  * the sign bit (LOCKID_MASK) being set).
7455  *
7456  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
7457  * name and its encoded form, but it seems very unlikely that we will find
7458  * two files on different disks that share the same encoded device names,
7459  * and even more remote that they will share the same file id (if the test
7460  * is to check for the same file).
7461  *
7462  * A better method might be to use sys$device_scan on the first call, and to
7463  * search for the device, returning an index into the cached array.
7464  * The number returned would be more intelligable.
7465  * This is probably not worth it, and anyway would take quite a bit longer
7466  * on the first call.
7467  */
7468 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
7469 static mydev_t encode_dev (pTHX_ const char *dev)
7470 {
7471   int i;
7472   unsigned long int f;
7473   mydev_t enc;
7474   char c;
7475   const char *q;
7476
7477   if (!dev || !dev[0]) return 0;
7478
7479 #if LOCKID_MASK
7480   {
7481     struct dsc$descriptor_s dev_desc;
7482     unsigned long int status, lockid, item = DVI$_LOCKID;
7483
7484     /* For cluster-mounted disks, the disk lock identifier is unique, so we
7485        can try that first. */
7486     dev_desc.dsc$w_length =  strlen (dev);
7487     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
7488     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
7489     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
7490     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
7491     if (lockid) return (lockid & ~LOCKID_MASK);
7492   }
7493 #endif
7494
7495   /* Otherwise we try to encode the device name */
7496   enc = 0;
7497   f = 1;
7498   i = 0;
7499   for (q = dev + strlen(dev); q--; q >= dev) {
7500     if (isdigit (*q))
7501       c= (*q) - '0';
7502     else if (isalpha (toupper (*q)))
7503       c= toupper (*q) - 'A' + (char)10;
7504     else
7505       continue; /* Skip '$'s */
7506     i++;
7507     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
7508     if (i>1) f *= 36;
7509     enc += f * (unsigned long int) c;
7510   }
7511   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
7512
7513 }  /* end of encode_dev() */
7514
7515 static char namecache[NAM$C_MAXRSS+1];
7516
7517 static int
7518 is_null_device(name)
7519     const char *name;
7520 {
7521     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
7522        The underscore prefix, controller letter, and unit number are
7523        independently optional; for our purposes, the colon punctuation
7524        is not.  The colon can be trailed by optional directory and/or
7525        filename, but two consecutive colons indicates a nodename rather
7526        than a device.  [pr]  */
7527   if (*name == '_') ++name;
7528   if (tolower(*name++) != 'n') return 0;
7529   if (tolower(*name++) != 'l') return 0;
7530   if (tolower(*name) == 'a') ++name;
7531   if (*name == '0') ++name;
7532   return (*name++ == ':') && (*name != ':');
7533 }
7534
7535 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
7536 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
7537  * subset of the applicable information.
7538  */
7539 bool
7540 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
7541 {
7542   char fname_phdev[NAM$C_MAXRSS+1];
7543   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
7544   else {
7545     char fname[NAM$C_MAXRSS+1];
7546     unsigned long int retsts;
7547     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7548                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7549
7550     /* If the struct mystat is stale, we're OOL; stat() overwrites the
7551        device name on successive calls */
7552     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
7553     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
7554     namdsc.dsc$a_pointer = fname;
7555     namdsc.dsc$w_length = sizeof fname - 1;
7556
7557     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
7558                              &namdsc,&namdsc.dsc$w_length,0,0);
7559     if (retsts & 1) {
7560       fname[namdsc.dsc$w_length] = '\0';
7561 /*
7562  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
7563  * but if someone has redefined that logical, Perl gets very lost.  Since
7564  * we have the physical device name from the stat buffer, just paste it on.
7565  */
7566       strcpy( fname_phdev, statbufp->st_devnam );
7567       strcat( fname_phdev, strrchr(fname, ':') );
7568
7569       return cando_by_name(bit,effective,fname_phdev);
7570     }
7571     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
7572       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
7573       return FALSE;
7574     }
7575     _ckvmssts(retsts);
7576     return FALSE;  /* Should never get to here */
7577   }
7578 }  /* end of cando() */
7579 /*}}}*/
7580
7581
7582 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
7583 I32
7584 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
7585 {
7586   static char usrname[L_cuserid];
7587   static struct dsc$descriptor_s usrdsc =
7588          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
7589   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
7590   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
7591   unsigned short int retlen, trnlnm_iter_count;
7592   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7593   union prvdef curprv;
7594   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
7595          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
7596   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
7597          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
7598          {0,0,0,0}};
7599   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
7600          {0,0,0,0}};
7601   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7602
7603   if (!fname || !*fname) return FALSE;
7604   /* Make sure we expand logical names, since sys$check_access doesn't */
7605   if (!strpbrk(fname,"/]>:")) {
7606     strcpy(fileified,fname);
7607     trnlnm_iter_count = 0;
7608     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
7609         trnlnm_iter_count++;
7610         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
7611     }
7612     fname = fileified;
7613   }
7614   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
7615   retlen = namdsc.dsc$w_length = strlen(vmsname);
7616   namdsc.dsc$a_pointer = vmsname;
7617   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
7618       vmsname[retlen-1] == ':') {
7619     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
7620     namdsc.dsc$w_length = strlen(fileified);
7621     namdsc.dsc$a_pointer = fileified;
7622   }
7623
7624   switch (bit) {
7625     case S_IXUSR: case S_IXGRP: case S_IXOTH:
7626       access = ARM$M_EXECUTE; break;
7627     case S_IRUSR: case S_IRGRP: case S_IROTH:
7628       access = ARM$M_READ; break;
7629     case S_IWUSR: case S_IWGRP: case S_IWOTH:
7630       access = ARM$M_WRITE; break;
7631     case S_IDUSR: case S_IDGRP: case S_IDOTH:
7632       access = ARM$M_DELETE; break;
7633     default:
7634       return FALSE;
7635   }
7636
7637   /* Before we call $check_access, create a user profile with the current
7638    * process privs since otherwise it just uses the default privs from the
7639    * UAF and might give false positives or negatives.  This only works on
7640    * VMS versions v6.0 and later since that's when sys$create_user_profile
7641    * became available.
7642    */
7643
7644   /* get current process privs and username */
7645   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
7646   _ckvmssts(iosb[0]);
7647
7648 #if defined(__VMS_VER) && __VMS_VER >= 60000000
7649
7650   /* find out the space required for the profile */
7651   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
7652                                     &usrprodsc.dsc$w_length,0));
7653
7654   /* allocate space for the profile and get it filled in */
7655   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
7656   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
7657                                     &usrprodsc.dsc$w_length,0));
7658
7659   /* use the profile to check access to the file; free profile & analyze results */
7660   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
7661   Safefree(usrprodsc.dsc$a_pointer);
7662   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
7663
7664 #else
7665
7666   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
7667
7668 #endif
7669
7670   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
7671       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
7672       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
7673     set_vaxc_errno(retsts);
7674     if (retsts == SS$_NOPRIV) set_errno(EACCES);
7675     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
7676     else set_errno(ENOENT);
7677     return FALSE;
7678   }
7679   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
7680     return TRUE;
7681   }
7682   _ckvmssts(retsts);
7683
7684   return FALSE;  /* Should never get here */
7685
7686 }  /* end of cando_by_name() */
7687 /*}}}*/
7688
7689
7690 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
7691 int
7692 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
7693 {
7694   if (!fstat(fd,(stat_t *) statbufp)) {
7695     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
7696     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7697 #   ifdef RTL_USES_UTC
7698 #   ifdef VMSISH_TIME
7699     if (VMSISH_TIME) {
7700       statbufp->st_mtime = _toloc(statbufp->st_mtime);
7701       statbufp->st_atime = _toloc(statbufp->st_atime);
7702       statbufp->st_ctime = _toloc(statbufp->st_ctime);
7703     }
7704 #   endif
7705 #   else
7706 #   ifdef VMSISH_TIME
7707     if (!VMSISH_TIME) { /* Return UTC instead of local time */
7708 #   else
7709     if (1) {
7710 #   endif
7711       statbufp->st_mtime = _toutc(statbufp->st_mtime);
7712       statbufp->st_atime = _toutc(statbufp->st_atime);
7713       statbufp->st_ctime = _toutc(statbufp->st_ctime);
7714     }
7715 #endif
7716     return 0;
7717   }
7718   return -1;
7719
7720 }  /* end of flex_fstat() */
7721 /*}}}*/
7722
7723 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
7724 int
7725 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
7726 {
7727     char fileified[NAM$C_MAXRSS+1];
7728     char temp_fspec[NAM$C_MAXRSS+300];
7729     int retval = -1;
7730     int saved_errno, saved_vaxc_errno;
7731
7732     if (!fspec) return retval;
7733     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
7734     strcpy(temp_fspec, fspec);
7735     if (statbufp == (Stat_t *) &PL_statcache)
7736       do_tovmsspec(temp_fspec,namecache,0);
7737     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
7738       memset(statbufp,0,sizeof *statbufp);
7739       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
7740       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
7741       statbufp->st_uid = 0x00010001;
7742       statbufp->st_gid = 0x0001;
7743       time((time_t *)&statbufp->st_mtime);
7744       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
7745       return 0;
7746     }
7747
7748     /* Try for a directory name first.  If fspec contains a filename without
7749      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
7750      * and sea:[wine.dark]water. exist, we prefer the directory here.
7751      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
7752      * not sea:[wine.dark]., if the latter exists.  If the intended target is
7753      * the file with null type, specify this by calling flex_stat() with
7754      * a '.' at the end of fspec.
7755      */
7756     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
7757       retval = stat(fileified,(stat_t *) statbufp);
7758       if (!retval && statbufp == (Stat_t *) &PL_statcache)
7759         strcpy(namecache,fileified);
7760     }
7761     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
7762     if (!retval) {
7763       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7764 #     ifdef RTL_USES_UTC
7765 #     ifdef VMSISH_TIME
7766       if (VMSISH_TIME) {
7767         statbufp->st_mtime = _toloc(statbufp->st_mtime);
7768         statbufp->st_atime = _toloc(statbufp->st_atime);
7769         statbufp->st_ctime = _toloc(statbufp->st_ctime);
7770       }
7771 #     endif
7772 #     else
7773 #     ifdef VMSISH_TIME
7774       if (!VMSISH_TIME) { /* Return UTC instead of local time */
7775 #     else
7776       if (1) {
7777 #     endif
7778         statbufp->st_mtime = _toutc(statbufp->st_mtime);
7779         statbufp->st_atime = _toutc(statbufp->st_atime);
7780         statbufp->st_ctime = _toutc(statbufp->st_ctime);
7781       }
7782 #     endif
7783     }
7784     /* If we were successful, leave errno where we found it */
7785     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
7786     return retval;
7787
7788 }  /* end of flex_stat() */
7789 /*}}}*/
7790
7791
7792 /*{{{char *my_getlogin()*/
7793 /* VMS cuserid == Unix getlogin, except calling sequence */
7794 char *
7795 my_getlogin(void)
7796 {
7797     static char user[L_cuserid];
7798     return cuserid(user);
7799 }
7800 /*}}}*/
7801
7802
7803 /*  rmscopy - copy a file using VMS RMS routines
7804  *
7805  *  Copies contents and attributes of spec_in to spec_out, except owner
7806  *  and protection information.  Name and type of spec_in are used as
7807  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
7808  *  should try to propagate timestamps from the input file to the output file.
7809  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
7810  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
7811  *  propagated to the output file at creation iff the output file specification
7812  *  did not contain an explicit name or type, and the revision date is always
7813  *  updated at the end of the copy operation.  If it is greater than 0, then
7814  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
7815  *  other than the revision date should be propagated, and bit 1 indicates
7816  *  that the revision date should be propagated.
7817  *
7818  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7819  *
7820  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7821  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
7822  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
7823  * as part of the Perl standard distribution under the terms of the
7824  * GNU General Public License or the Perl Artistic License.  Copies
7825  * of each may be found in the Perl standard distribution.
7826  */
7827 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7828 int
7829 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
7830 {
7831     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7832          rsa[NAM$C_MAXRSS], ubf[32256];
7833     unsigned long int i, sts, sts2;
7834     struct FAB fab_in, fab_out;
7835     struct RAB rab_in, rab_out;
7836     struct NAM nam;
7837     struct XABDAT xabdat;
7838     struct XABFHC xabfhc;
7839     struct XABRDT xabrdt;
7840     struct XABSUM xabsum;
7841
7842     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
7843         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7844       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7845       return 0;
7846     }
7847
7848     fab_in = cc$rms_fab;
7849     fab_in.fab$l_fna = vmsin;
7850     fab_in.fab$b_fns = strlen(vmsin);
7851     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7852     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7853     fab_in.fab$l_fop = FAB$M_SQO;
7854     fab_in.fab$l_nam =  &nam;
7855     fab_in.fab$l_xab = (void *) &xabdat;
7856
7857     nam = cc$rms_nam;
7858     nam.nam$l_rsa = rsa;
7859     nam.nam$b_rss = sizeof(rsa);
7860     nam.nam$l_esa = esa;
7861     nam.nam$b_ess = sizeof (esa);
7862     nam.nam$b_esl = nam.nam$b_rsl = 0;
7863 #ifdef NAM$M_NO_SHORT_UPCASE
7864     if (decc_efs_case_preserve)
7865         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7866 #endif
7867
7868     xabdat = cc$rms_xabdat;        /* To get creation date */
7869     xabdat.xab$l_nxt = (void *) &xabfhc;
7870
7871     xabfhc = cc$rms_xabfhc;        /* To get record length */
7872     xabfhc.xab$l_nxt = (void *) &xabsum;
7873
7874     xabsum = cc$rms_xabsum;        /* To get key and area information */
7875
7876     if (!((sts = sys$open(&fab_in)) & 1)) {
7877       set_vaxc_errno(sts);
7878       switch (sts) {
7879         case RMS$_FNF: case RMS$_DNF:
7880           set_errno(ENOENT); break;
7881         case RMS$_DIR:
7882           set_errno(ENOTDIR); break;
7883         case RMS$_DEV:
7884           set_errno(ENODEV); break;
7885         case RMS$_SYN:
7886           set_errno(EINVAL); break;
7887         case RMS$_PRV:
7888           set_errno(EACCES); break;
7889         default:
7890           set_errno(EVMSERR);
7891       }
7892       return 0;
7893     }
7894
7895     fab_out = fab_in;
7896     fab_out.fab$w_ifi = 0;
7897     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7898     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7899     fab_out.fab$l_fop = FAB$M_SQO;
7900     fab_out.fab$l_fna = vmsout;
7901     fab_out.fab$b_fns = strlen(vmsout);
7902     fab_out.fab$l_dna = nam.nam$l_name;
7903     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7904
7905     if (preserve_dates == 0) {  /* Act like DCL COPY */
7906       nam.nam$b_nop |= NAM$M_SYNCHK;
7907       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
7908       if (!((sts = sys$parse(&fab_out)) & 1)) {
7909         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7910         set_vaxc_errno(sts);
7911         return 0;
7912       }
7913       fab_out.fab$l_xab = (void *) &xabdat;
7914       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7915     }
7916     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
7917     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
7918       preserve_dates =0;      /* bitmask from this point forward   */
7919
7920     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7921     if (!((sts = sys$create(&fab_out)) & 1)) {
7922       set_vaxc_errno(sts);
7923       switch (sts) {
7924         case RMS$_DNF:
7925           set_errno(ENOENT); break;
7926         case RMS$_DIR:
7927           set_errno(ENOTDIR); break;
7928         case RMS$_DEV:
7929           set_errno(ENODEV); break;
7930         case RMS$_SYN:
7931           set_errno(EINVAL); break;
7932         case RMS$_PRV:
7933           set_errno(EACCES); break;
7934         default:
7935           set_errno(EVMSERR);
7936       }
7937       return 0;
7938     }
7939     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
7940     if (preserve_dates & 2) {
7941       /* sys$close() will process xabrdt, not xabdat */
7942       xabrdt = cc$rms_xabrdt;
7943 #ifndef __GNUC__
7944       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7945 #else
7946       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7947        * is unsigned long[2], while DECC & VAXC use a struct */
7948       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7949 #endif
7950       fab_out.fab$l_xab = (void *) &xabrdt;
7951     }
7952
7953     rab_in = cc$rms_rab;
7954     rab_in.rab$l_fab = &fab_in;
7955     rab_in.rab$l_rop = RAB$M_BIO;
7956     rab_in.rab$l_ubf = ubf;
7957     rab_in.rab$w_usz = sizeof ubf;
7958     if (!((sts = sys$connect(&rab_in)) & 1)) {
7959       sys$close(&fab_in); sys$close(&fab_out);
7960       set_errno(EVMSERR); set_vaxc_errno(sts);
7961       return 0;
7962     }
7963
7964     rab_out = cc$rms_rab;
7965     rab_out.rab$l_fab = &fab_out;
7966     rab_out.rab$l_rbf = ubf;
7967     if (!((sts = sys$connect(&rab_out)) & 1)) {
7968       sys$close(&fab_in); sys$close(&fab_out);
7969       set_errno(EVMSERR); set_vaxc_errno(sts);
7970       return 0;
7971     }
7972
7973     while ((sts = sys$read(&rab_in))) {  /* always true  */
7974       if (sts == RMS$_EOF) break;
7975       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7976       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7977         sys$close(&fab_in); sys$close(&fab_out);
7978         set_errno(EVMSERR); set_vaxc_errno(sts);
7979         return 0;
7980       }
7981     }
7982
7983     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
7984     sys$close(&fab_in);  sys$close(&fab_out);
7985     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7986     if (!(sts & 1)) {
7987       set_errno(EVMSERR); set_vaxc_errno(sts);
7988       return 0;
7989     }
7990
7991     return 1;
7992
7993 }  /* end of rmscopy() */
7994 /*}}}*/
7995
7996
7997 /***  The following glue provides 'hooks' to make some of the routines
7998  * from this file available from Perl.  These routines are sufficiently
7999  * basic, and are required sufficiently early in the build process,
8000  * that's it's nice to have them available to miniperl as well as the
8001  * full Perl, so they're set up here instead of in an extension.  The
8002  * Perl code which handles importation of these names into a given
8003  * package lives in [.VMS]Filespec.pm in @INC.
8004  */
8005
8006 void
8007 rmsexpand_fromperl(pTHX_ CV *cv)
8008 {
8009   dXSARGS;
8010   char *fspec, *defspec = NULL, *rslt;
8011   STRLEN n_a;
8012
8013   if (!items || items > 2)
8014     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
8015   fspec = SvPV(ST(0),n_a);
8016   if (!fspec || !*fspec) XSRETURN_UNDEF;
8017   if (items == 2) defspec = SvPV(ST(1),n_a);
8018
8019   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
8020   ST(0) = sv_newmortal();
8021   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
8022   XSRETURN(1);
8023 }
8024
8025 void
8026 vmsify_fromperl(pTHX_ CV *cv)
8027 {
8028   dXSARGS;
8029   char *vmsified;
8030   STRLEN n_a;
8031
8032   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
8033   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
8034   ST(0) = sv_newmortal();
8035   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
8036   XSRETURN(1);
8037 }
8038
8039 void
8040 unixify_fromperl(pTHX_ CV *cv)
8041 {
8042   dXSARGS;
8043   char *unixified;
8044   STRLEN n_a;
8045
8046   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
8047   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
8048   ST(0) = sv_newmortal();
8049   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
8050   XSRETURN(1);
8051 }
8052
8053 void
8054 fileify_fromperl(pTHX_ CV *cv)
8055 {
8056   dXSARGS;
8057   char *fileified;
8058   STRLEN n_a;
8059
8060   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
8061   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
8062   ST(0) = sv_newmortal();
8063   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
8064   XSRETURN(1);
8065 }
8066
8067 void
8068 pathify_fromperl(pTHX_ CV *cv)
8069 {
8070   dXSARGS;
8071   char *pathified;
8072   STRLEN n_a;
8073
8074   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
8075   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
8076   ST(0) = sv_newmortal();
8077   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
8078   XSRETURN(1);
8079 }
8080
8081 void
8082 vmspath_fromperl(pTHX_ CV *cv)
8083 {
8084   dXSARGS;
8085   char *vmspath;
8086   STRLEN n_a;
8087
8088   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
8089   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
8090   ST(0) = sv_newmortal();
8091   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
8092   XSRETURN(1);
8093 }
8094
8095 void
8096 unixpath_fromperl(pTHX_ CV *cv)
8097 {
8098   dXSARGS;
8099   char *unixpath;
8100   STRLEN n_a;
8101
8102   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
8103   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
8104   ST(0) = sv_newmortal();
8105   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
8106   XSRETURN(1);
8107 }
8108
8109 void
8110 candelete_fromperl(pTHX_ CV *cv)
8111 {
8112   dXSARGS;
8113   char fspec[NAM$C_MAXRSS+1], *fsp;
8114   SV *mysv;
8115   IO *io;
8116   STRLEN n_a;
8117
8118   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
8119
8120   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8121   if (SvTYPE(mysv) == SVt_PVGV) {
8122     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
8123       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8124       ST(0) = &PL_sv_no;
8125       XSRETURN(1);
8126     }
8127     fsp = fspec;
8128   }
8129   else {
8130     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
8131       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8132       ST(0) = &PL_sv_no;
8133       XSRETURN(1);
8134     }
8135   }
8136
8137   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
8138   XSRETURN(1);
8139 }
8140
8141 void
8142 rmscopy_fromperl(pTHX_ CV *cv)
8143 {
8144   dXSARGS;
8145   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
8146   int date_flag;
8147   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
8148                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8149   unsigned long int sts;
8150   SV *mysv;
8151   IO *io;
8152   STRLEN n_a;
8153
8154   if (items < 2 || items > 3)
8155     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
8156
8157   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8158   if (SvTYPE(mysv) == SVt_PVGV) {
8159     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
8160       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8161       ST(0) = &PL_sv_no;
8162       XSRETURN(1);
8163     }
8164     inp = inspec;
8165   }
8166   else {
8167     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
8168       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8169       ST(0) = &PL_sv_no;
8170       XSRETURN(1);
8171     }
8172   }
8173   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
8174   if (SvTYPE(mysv) == SVt_PVGV) {
8175     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
8176       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8177       ST(0) = &PL_sv_no;
8178       XSRETURN(1);
8179     }
8180     outp = outspec;
8181   }
8182   else {
8183     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
8184       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8185       ST(0) = &PL_sv_no;
8186       XSRETURN(1);
8187     }
8188   }
8189   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
8190
8191   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
8192   XSRETURN(1);
8193 }
8194
8195
8196 void
8197 mod2fname(pTHX_ CV *cv)
8198 {
8199   dXSARGS;
8200   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
8201        workbuff[NAM$C_MAXRSS*1 + 1];
8202   int total_namelen = 3, counter, num_entries;
8203   /* ODS-5 ups this, but we want to be consistent, so... */
8204   int max_name_len = 39;
8205   AV *in_array = (AV *)SvRV(ST(0));
8206
8207   num_entries = av_len(in_array);
8208
8209   /* All the names start with PL_. */
8210   strcpy(ultimate_name, "PL_");
8211
8212   /* Clean up our working buffer */
8213   Zero(work_name, sizeof(work_name), char);
8214
8215   /* Run through the entries and build up a working name */
8216   for(counter = 0; counter <= num_entries; counter++) {
8217     /* If it's not the first name then tack on a __ */
8218     if (counter) {
8219       strcat(work_name, "__");
8220     }
8221     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
8222                            PL_na));
8223   }
8224
8225   /* Check to see if we actually have to bother...*/
8226   if (strlen(work_name) + 3 <= max_name_len) {
8227     strcat(ultimate_name, work_name);
8228   } else {
8229     /* It's too darned big, so we need to go strip. We use the same */
8230     /* algorithm as xsubpp does. First, strip out doubled __ */
8231     char *source, *dest, last;
8232     dest = workbuff;
8233     last = 0;
8234     for (source = work_name; *source; source++) {
8235       if (last == *source && last == '_') {
8236         continue;
8237       }
8238       *dest++ = *source;
8239       last = *source;
8240     }
8241     /* Go put it back */
8242     strcpy(work_name, workbuff);
8243     /* Is it still too big? */
8244     if (strlen(work_name) + 3 > max_name_len) {
8245       /* Strip duplicate letters */
8246       last = 0;
8247       dest = workbuff;
8248       for (source = work_name; *source; source++) {
8249         if (last == toupper(*source)) {
8250         continue;
8251         }
8252         *dest++ = *source;
8253         last = toupper(*source);
8254       }
8255       strcpy(work_name, workbuff);
8256     }
8257
8258     /* Is it *still* too big? */
8259     if (strlen(work_name) + 3 > max_name_len) {
8260       /* Too bad, we truncate */
8261       work_name[max_name_len - 2] = 0;
8262     }
8263     strcat(ultimate_name, work_name);
8264   }
8265
8266   /* Okay, return it */
8267   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
8268   XSRETURN(1);
8269 }
8270
8271 void
8272 hushexit_fromperl(pTHX_ CV *cv)
8273 {
8274     dXSARGS;
8275
8276     if (items > 0) {
8277         VMSISH_HUSHED = SvTRUE(ST(0));
8278     }
8279     ST(0) = boolSV(VMSISH_HUSHED);
8280     XSRETURN(1);
8281 }
8282
8283 void
8284 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
8285                           struct interp_intern *dst)
8286 {
8287     memcpy(dst,src,sizeof(struct interp_intern));
8288 }
8289
8290 void
8291 Perl_sys_intern_clear(pTHX)
8292 {
8293 }
8294
8295 void
8296 Perl_sys_intern_init(pTHX)
8297 {
8298     unsigned int ix = RAND_MAX;
8299     double x;
8300
8301     VMSISH_HUSHED = 0;
8302
8303     x = (float)ix;
8304     MY_INV_RAND_MAX = 1./x;
8305 }
8306
8307 void
8308 init_os_extras(void)
8309 {
8310   dTHX;
8311   char* file = __FILE__;
8312   char temp_buff[512];
8313   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
8314     no_translate_barewords = TRUE;
8315   } else {
8316     no_translate_barewords = FALSE;
8317   }
8318
8319   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
8320   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
8321   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
8322   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
8323   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
8324   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
8325   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
8326   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
8327   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
8328   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
8329   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
8330 #ifdef HAS_SYMLINK
8331   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
8332 #endif
8333 #if 0 /* future */
8334 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8335   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
8336 #endif
8337 #endif
8338
8339   store_pipelocs(aTHX);         /* will redo any earlier attempts */
8340
8341   return;
8342 }
8343
8344 #ifdef HAS_SYMLINK
8345
8346 #if __CRTL_VER == 80200000
8347 /* This missed getting in to the DECC SDK for 8.2 */
8348 char *realpath(const char *file_name, char * resolved_name, ...);
8349 #endif
8350
8351 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
8352 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
8353  * The perl fallback routine to provide realpath() is not as efficient
8354  * on OpenVMS.
8355  */
8356 static char *
8357 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8358 {
8359     return realpath(filespec, outbuf);
8360 }
8361
8362 /*}}}*/
8363 /* External entry points */
8364 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8365 { return do_vms_realpath(filespec, outbuf); }
8366 #else
8367 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8368 { return NULL; }
8369 #endif
8370
8371
8372 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8373 /* case_tolerant */
8374
8375 /*{{{int do_vms_case_tolerant(void)*/
8376 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
8377  * controlled by a process setting.
8378  */
8379 int do_vms_case_tolerant(void)
8380 {
8381     return vms_process_case_tolerant;
8382 }
8383 /*}}}*/
8384 /* External entry points */
8385 int Perl_vms_case_tolerant(void)
8386 { return do_vms_case_tolerant(); }
8387 #else
8388 int Perl_vms_case_tolerant(void)
8389 { return vms_process_case_tolerant; }
8390 #endif
8391
8392
8393  /* Start of DECC RTL Feature handling */
8394
8395 static int sys_trnlnm
8396    (const char * logname,
8397     char * value,
8398     int value_len)
8399 {
8400     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
8401     const unsigned long attr = LNM$M_CASE_BLIND;
8402     struct dsc$descriptor_s name_dsc;
8403     int status;
8404     unsigned short result;
8405     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
8406                                 {0, 0, 0, 0}};
8407
8408     name_dsc.dsc$w_length = strlen(logname);
8409     name_dsc.dsc$a_pointer = (char *)logname;
8410     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8411     name_dsc.dsc$b_class = DSC$K_CLASS_S;
8412
8413     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
8414
8415     if ($VMS_STATUS_SUCCESS(status)) {
8416
8417          /* Null terminate and return the string */
8418         /*--------------------------------------*/
8419         value[result] = 0;
8420     }
8421
8422     return status;
8423 }
8424
8425 static int sys_crelnm
8426    (const char * logname,
8427     const char * value)
8428 {
8429     int ret_val;
8430     const char * proc_table = "LNM$PROCESS_TABLE";
8431     struct dsc$descriptor_s proc_table_dsc;
8432     struct dsc$descriptor_s logname_dsc;
8433     struct itmlst_3 item_list[2];
8434
8435     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
8436     proc_table_dsc.dsc$w_length = strlen(proc_table);
8437     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8438     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
8439
8440     logname_dsc.dsc$a_pointer = (char *) logname;
8441     logname_dsc.dsc$w_length = strlen(logname);
8442     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8443     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
8444
8445     item_list[0].buflen = strlen(value);
8446     item_list[0].itmcode = LNM$_STRING;
8447     item_list[0].bufadr = (char *)value;
8448     item_list[0].retlen = NULL;
8449
8450     item_list[1].buflen = 0;
8451     item_list[1].itmcode = 0;
8452
8453     ret_val = sys$crelnm
8454                        (NULL,
8455                         (const struct dsc$descriptor_s *)&proc_table_dsc,
8456                         (const struct dsc$descriptor_s *)&logname_dsc,
8457                         NULL,
8458                         (const struct item_list_3 *) item_list);
8459
8460     return ret_val;
8461 }
8462
8463
8464 /* C RTL Feature settings */
8465
8466 static int set_features
8467    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
8468     int (* cli_routine)(void),  /* Not documented */
8469     void *image_info)           /* Not documented */
8470 {
8471     int status;
8472     int s;
8473     int dflt;
8474     char* str;
8475     char val_str[10];
8476     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
8477     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
8478     unsigned long case_perm;
8479     unsigned long case_image;
8480
8481 #if __CRTL_VER >= 70300000 && !defined(__VAX)
8482     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
8483     if (s >= 0) {
8484         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
8485         if (decc_disable_to_vms_logname_translation < 0)
8486             decc_disable_to_vms_logname_translation = 0;
8487     }
8488
8489     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
8490     if (s >= 0) {
8491         decc_efs_case_preserve = decc$feature_get_value(s, 1);
8492         if (decc_efs_case_preserve < 0)
8493             decc_efs_case_preserve = 0;
8494     }
8495
8496     s = decc$feature_get_index("DECC$EFS_CHARSET");
8497     if (s >= 0) {
8498         decc_efs_charset = decc$feature_get_value(s, 1);
8499         if (decc_efs_charset < 0)
8500             decc_efs_charset = 0;
8501     }
8502
8503     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
8504     if (s >= 0) {
8505         decc_filename_unix_report = decc$feature_get_value(s, 1);
8506         if (decc_filename_unix_report > 0)
8507             decc_filename_unix_report = 1;
8508         else
8509             decc_filename_unix_report = 0;
8510     }
8511
8512     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
8513     if (s >= 0) {
8514         decc_filename_unix_only = decc$feature_get_value(s, 1);
8515         if (decc_filename_unix_only > 0) {
8516             decc_filename_unix_only = 1;
8517         }
8518         else {
8519             decc_filename_unix_only = 0;
8520         }
8521     }
8522
8523     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
8524     if (s >= 0) {
8525         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
8526         if (decc_filename_unix_no_version < 0)
8527             decc_filename_unix_no_version = 0;
8528     }
8529
8530     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
8531     if (s >= 0) {
8532         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
8533         if (decc_readdir_dropdotnotype < 0)
8534             decc_readdir_dropdotnotype = 0;
8535     }
8536
8537     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
8538     if ($VMS_STATUS_SUCCESS(status)) {
8539         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
8540         if (s >= 0) {
8541             dflt = decc$feature_get_value(s, 4);
8542             if (dflt > 0) {
8543                 decc_disable_posix_root = decc$feature_get_value(s, 1);
8544                 if (decc_disable_posix_root <= 0) {
8545                     decc$feature_set_value(s, 1, 1);
8546                     decc_disable_posix_root = 1;
8547                 }
8548             }
8549             else {
8550                 /* Traditionally Perl assumes this is off */
8551                 decc_disable_posix_root = 1;
8552                 decc$feature_set_value(s, 1, 1);
8553             }
8554         }
8555     }
8556
8557 #if __CRTL_VER >= 80200000
8558     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
8559     if (s >= 0) {
8560         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
8561         if (decc_posix_compliant_pathnames < 0)
8562             decc_posix_compliant_pathnames = 0;
8563         if (decc_posix_compliant_pathnames > 4)
8564             decc_posix_compliant_pathnames = 0;
8565     }
8566
8567 #endif
8568 #else
8569     status = sys_trnlnm
8570         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
8571     if ($VMS_STATUS_SUCCESS(status)) {
8572         val_str[0] = _toupper(val_str[0]);
8573         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8574            decc_disable_to_vms_logname_translation = 1;
8575         }
8576     }
8577
8578 #ifndef __VAX
8579     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
8580     if ($VMS_STATUS_SUCCESS(status)) {
8581         val_str[0] = _toupper(val_str[0]);
8582         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8583            decc_efs_case_preserve = 1;
8584         }
8585     }
8586 #endif
8587
8588     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
8589     if ($VMS_STATUS_SUCCESS(status)) {
8590         val_str[0] = _toupper(val_str[0]);
8591         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8592            decc_filename_unix_report = 1;
8593         }
8594     }
8595     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
8596     if ($VMS_STATUS_SUCCESS(status)) {
8597         val_str[0] = _toupper(val_str[0]);
8598         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8599            decc_filename_unix_only = 1;
8600            decc_filename_unix_report = 1;
8601         }
8602     }
8603     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
8604     if ($VMS_STATUS_SUCCESS(status)) {
8605         val_str[0] = _toupper(val_str[0]);
8606         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8607            decc_filename_unix_no_version = 1;
8608         }
8609     }
8610     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
8611     if ($VMS_STATUS_SUCCESS(status)) {
8612         val_str[0] = _toupper(val_str[0]);
8613         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8614            decc_readdir_dropdotnotype = 1;
8615         }
8616     }
8617 #endif
8618
8619 #ifndef __VAX
8620
8621      /* Report true case tolerance */
8622     /*----------------------------*/
8623     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
8624     if (!$VMS_STATUS_SUCCESS(status))
8625         case_perm = PPROP$K_CASE_BLIND;
8626     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
8627     if (!$VMS_STATUS_SUCCESS(status))
8628         case_image = PPROP$K_CASE_BLIND;
8629     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
8630         (case_image == PPROP$K_CASE_SENSITIVE))
8631         vms_process_case_tolerant = 0;
8632
8633 #endif
8634
8635
8636     /* CRTL can be initialized past this point, but not before. */
8637 /*    DECC$CRTL_INIT(); */
8638
8639     return SS$_NORMAL;
8640 }
8641
8642 #ifdef __DECC
8643 /* DECC dependent attributes */
8644 #if __DECC_VER < 60560002
8645 #define relative
8646 #define not_executable
8647 #else
8648 #define relative ,rel
8649 #define not_executable ,noexe
8650 #endif
8651 #pragma nostandard
8652 #pragma extern_model save
8653 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
8654 #endif
8655         const __align (LONGWORD) int spare[8] = {0};
8656 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
8657 /*                        NOWRT, LONG */
8658 #ifdef __DECC
8659 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
8660         nowrt,noshr relative not_executable
8661 #endif
8662 const long vms_cc_features = (const long)set_features;
8663
8664 /*
8665 ** Force a reference to LIB$INITIALIZE to ensure it
8666 ** exists in the image.
8667 */
8668 int lib$initialize(void);
8669 #ifdef __DECC
8670 #pragma extern_model strict_refdef
8671 #endif
8672     int lib_init_ref = (int) lib$initialize;
8673
8674 #ifdef __DECC
8675 #pragma extern_model restore
8676 #pragma standard
8677 #endif
8678
8679 /*  End of vms.c */