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,NAM$C_MAXRSS+1,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 (decc_disable_posix_root) {
4406         strcpy(rslt,"sys$disk:[000000]");
4407       }
4408       else {
4409         strcpy(rslt,"sys$posix_root:[000000]");
4410       }
4411       return rslt;
4412     }
4413     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
4414     *cp1 = '\0';
4415     islnm =  my_trnlnm(rslt,trndev,0);
4416
4417      /* DECC special handling */
4418     if (!islnm) {
4419       if (strcmp(rslt,"bin") == 0) {
4420         strcpy(rslt,"sys$system");
4421         cp1 = rslt + 10;
4422         *cp1 = 0;
4423         islnm =  my_trnlnm(rslt,trndev,0);
4424       }
4425       else if (strcmp(rslt,"tmp") == 0) {
4426         strcpy(rslt,"sys$scratch");
4427         cp1 = rslt + 11;
4428         *cp1 = 0;
4429         islnm =  my_trnlnm(rslt,trndev,0);
4430       }
4431       else if (!decc_disable_posix_root) {
4432         strcpy(rslt, "sys$posix_root");
4433         cp1 = rslt + 13;
4434         *cp1 = 0;
4435         cp2 = path;
4436         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
4437         islnm =  my_trnlnm(rslt,trndev,0);
4438       }
4439       else if (strcmp(rslt,"dev") == 0) {
4440         if (strncmp(cp2,"/null", 5) == 0) {
4441           if ((cp2[5] == 0) || (cp2[5] == '/')) {
4442             strcpy(rslt,"NLA0");
4443             cp1 = rslt + 4;
4444             *cp1 = 0;
4445             cp2 = cp2 + 5;
4446             islnm =  my_trnlnm(rslt,trndev,0);
4447           }
4448         }
4449       }
4450     }
4451
4452     trnend = islnm ? strlen(trndev) - 1 : 0;
4453     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
4454     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
4455     /* If the first element of the path is a logical name, determine
4456      * whether it has to be translated so we can add more directories. */
4457     if (!islnm || rooted) {
4458       *(cp1++) = ':';
4459       *(cp1++) = '[';
4460       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
4461       else cp2++;
4462     }
4463     else {
4464       if (cp2 != dirend) {
4465         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
4466         strcpy(rslt,trndev);
4467         cp1 = rslt + trnend;
4468         if (*cp2 != 0) {
4469           *(cp1++) = '.';
4470           cp2++;
4471         }
4472       }
4473       else {
4474         if (decc_disable_posix_root) {
4475           *(cp1++) = ':';
4476           hasdir = 0;
4477         }
4478       }
4479     }
4480   }
4481   else {
4482     *(cp1++) = '[';
4483     if (*cp2 == '.') {
4484       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
4485         cp2 += 2;         /* skip over "./" - it's redundant */
4486         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
4487       }
4488       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4489         *(cp1++) = '-';                                 /* "../" --> "-" */
4490         cp2 += 3;
4491       }
4492       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
4493                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
4494         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4495         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
4496         cp2 += 4;
4497       }
4498       else if ((cp2 != lastdot) || (lastdot < dirend)) {
4499         /* Escape the extra dots in EFS file specifications */
4500         *(cp1++) = '^';
4501       }
4502       if (cp2 > dirend) cp2 = dirend;
4503     }
4504     else *(cp1++) = '.';
4505   }
4506   for (; cp2 < dirend; cp2++) {
4507     if (*cp2 == '/') {
4508       if (*(cp2-1) == '/') continue;
4509       if (*(cp1-1) != '.') *(cp1++) = '.';
4510       infront = 0;
4511     }
4512     else if (!infront && *cp2 == '.') {
4513       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
4514       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
4515       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4516         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
4517         else if (*(cp1-2) == '[') *(cp1-1) = '-';
4518         else {  /* back up over previous directory name */
4519           cp1--;
4520           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4521           if (*(cp1-1) == '[') {
4522             memcpy(cp1,"000000.",7);
4523             cp1 += 7;
4524           }
4525         }
4526         cp2 += 2;
4527         if (cp2 == dirend) break;
4528       }
4529       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
4530                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
4531         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
4532         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4533         if (!*(cp2+3)) {
4534           *(cp1++) = '.';  /* Simulate trailing '/' */
4535           cp2 += 2;  /* for loop will incr this to == dirend */
4536         }
4537         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
4538       }
4539       else {
4540         if (decc_efs_charset == 0)
4541           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
4542         else {
4543           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
4544           *(cp1++) = '.';
4545         }
4546       }
4547     }
4548     else {
4549       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
4550       if (*cp2 == '.') {
4551         if (decc_efs_charset == 0)
4552           *(cp1++) = '_';
4553         else {
4554           *(cp1++) = '^';
4555           *(cp1++) = '.';
4556         }
4557       }
4558       else                  *(cp1++) =  *cp2;
4559       infront = 1;
4560     }
4561   }
4562   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
4563   if (hasdir) *(cp1++) = ']';
4564   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
4565   /* fixme for ODS5 */
4566   no_type_seen = 0;
4567   if (cp2 > lastdot)
4568     no_type_seen = 1;
4569   while (*cp2) {
4570     switch(*cp2) {
4571     case '?':
4572         *(cp1++) = '%';
4573         cp2++;
4574     case ' ':
4575         *(cp1)++ = '^';
4576         *(cp1)++ = '_';
4577         cp2++;
4578         break;
4579     case '.':
4580         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
4581             decc_readdir_dropdotnotype) {
4582           *(cp1)++ = '^';
4583           *(cp1)++ = '.';
4584           cp2++;
4585
4586           /* trailing dot ==> '^..' on VMS */
4587           if (*cp2 == '\0') {
4588             *(cp1++) = '.';
4589             no_type_seen = 0;
4590           }
4591         }
4592         else {
4593           *(cp1++) = *(cp2++);
4594           no_type_seen = 0;
4595         }
4596         break;
4597     case '\"':
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         *(cp1++) = '^';
4621         *(cp1++) = *(cp2++);
4622         break;
4623     case ';':
4624         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
4625          * which is wrong.  UNIX notation should be ".dir. unless
4626          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
4627          * changing this behavior could break more things at this time.
4628          */
4629         if (decc_filename_unix_report != 0) {
4630           *(cp1++) = '^';
4631         }
4632         *(cp1++) = *(cp2++);
4633         break;
4634     default:
4635         *(cp1++) = *(cp2++);
4636     }
4637   }
4638   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
4639   char *lcp1;
4640     lcp1 = cp1;
4641     lcp1--;
4642      /* Fix me for "^]", but that requires making sure that you do
4643       * not back up past the start of the filename
4644       */
4645     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
4646       *cp1++ = '.';
4647   }
4648   *cp1 = '\0';
4649
4650   return rslt;
4651
4652 }  /* end of do_tovmsspec() */
4653 /*}}}*/
4654 /* External entry points */
4655 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
4656 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
4657
4658 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
4659 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
4660   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
4661   int vmslen;
4662   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
4663
4664   if (path == NULL) return NULL;
4665   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4666   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
4667   if (buf) return buf;
4668   else if (ts) {
4669     vmslen = strlen(vmsified);
4670     Newx(cp,vmslen+1,char);
4671     memcpy(cp,vmsified,vmslen);
4672     cp[vmslen] = '\0';
4673     return cp;
4674   }
4675   else {
4676     strcpy(__tovmspath_retbuf,vmsified);
4677     return __tovmspath_retbuf;
4678   }
4679
4680 }  /* end of do_tovmspath() */
4681 /*}}}*/
4682 /* External entry points */
4683 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
4684 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
4685
4686
4687 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
4688 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
4689   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
4690   int unixlen;
4691   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
4692
4693   if (path == NULL) return NULL;
4694   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4695   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
4696   if (buf) return buf;
4697   else if (ts) {
4698     unixlen = strlen(unixified);
4699     Newx(cp,unixlen+1,char);
4700     memcpy(cp,unixified,unixlen);
4701     cp[unixlen] = '\0';
4702     return cp;
4703   }
4704   else {
4705     strcpy(__tounixpath_retbuf,unixified);
4706     return __tounixpath_retbuf;
4707   }
4708
4709 }  /* end of do_tounixpath() */
4710 /*}}}*/
4711 /* External entry points */
4712 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
4713 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
4714
4715 /*
4716  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
4717  *
4718  *****************************************************************************
4719  *                                                                           *
4720  *  Copyright (C) 1989-1994 by                                               *
4721  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
4722  *                                                                           *
4723  *  Permission is hereby  granted for the reproduction of this software,     *
4724  *  on condition that this copyright notice is included in the reproduction, *
4725  *  and that such reproduction is not for purposes of profit or material     *
4726  *  gain.                                                                    *
4727  *                                                                           *
4728  *  27-Aug-1994 Modified for inclusion in perl5                              *
4729  *              by Charles Bailey  bailey@newman.upenn.edu                   *
4730  *****************************************************************************
4731  */
4732
4733 /*
4734  * getredirection() is intended to aid in porting C programs
4735  * to VMS (Vax-11 C).  The native VMS environment does not support
4736  * '>' and '<' I/O redirection, or command line wild card expansion,
4737  * or a command line pipe mechanism using the '|' AND background
4738  * command execution '&'.  All of these capabilities are provided to any
4739  * C program which calls this procedure as the first thing in the
4740  * main program.
4741  * The piping mechanism will probably work with almost any 'filter' type
4742  * of program.  With suitable modification, it may useful for other
4743  * portability problems as well.
4744  *
4745  * Author:  Mark Pizzolato      mark@infocomm.com
4746  */
4747 struct list_item
4748     {
4749     struct list_item *next;
4750     char *value;
4751     };
4752
4753 static void add_item(struct list_item **head,
4754                      struct list_item **tail,
4755                      char *value,
4756                      int *count);
4757
4758 static void mp_expand_wild_cards(pTHX_ char *item,
4759                                 struct list_item **head,
4760                                 struct list_item **tail,
4761                                 int *count);
4762
4763 static int background_process(pTHX_ int argc, char **argv);
4764
4765 static void pipe_and_fork(pTHX_ char **cmargv);
4766
4767 /*{{{ void getredirection(int *ac, char ***av)*/
4768 static void
4769 mp_getredirection(pTHX_ int *ac, char ***av)
4770 /*
4771  * Process vms redirection arg's.  Exit if any error is seen.
4772  * If getredirection() processes an argument, it is erased
4773  * from the vector.  getredirection() returns a new argc and argv value.
4774  * In the event that a background command is requested (by a trailing "&"),
4775  * this routine creates a background subprocess, and simply exits the program.
4776  *
4777  * Warning: do not try to simplify the code for vms.  The code
4778  * presupposes that getredirection() is called before any data is
4779  * read from stdin or written to stdout.
4780  *
4781  * Normal usage is as follows:
4782  *
4783  *      main(argc, argv)
4784  *      int             argc;
4785  *      char            *argv[];
4786  *      {
4787  *              getredirection(&argc, &argv);
4788  *      }
4789  */
4790 {
4791     int                 argc = *ac;     /* Argument Count         */
4792     char                **argv = *av;   /* Argument Vector        */
4793     char                *ap;            /* Argument pointer       */
4794     int                 j;              /* argv[] index           */
4795     int                 item_count = 0; /* Count of Items in List */
4796     struct list_item    *list_head = 0; /* First Item in List       */
4797     struct list_item    *list_tail;     /* Last Item in List        */
4798     char                *in = NULL;     /* Input File Name          */
4799     char                *out = NULL;    /* Output File Name         */
4800     char                *outmode = "w"; /* Mode to Open Output File */
4801     char                *err = NULL;    /* Error File Name          */
4802     char                *errmode = "w"; /* Mode to Open Error File  */
4803     int                 cmargc = 0;     /* Piped Command Arg Count  */
4804     char                **cmargv = NULL;/* Piped Command Arg Vector */
4805
4806     /*
4807      * First handle the case where the last thing on the line ends with
4808      * a '&'.  This indicates the desire for the command to be run in a
4809      * subprocess, so we satisfy that desire.
4810      */
4811     ap = argv[argc-1];
4812     if (0 == strcmp("&", ap))
4813        exit(background_process(aTHX_ --argc, argv));
4814     if (*ap && '&' == ap[strlen(ap)-1])
4815         {
4816         ap[strlen(ap)-1] = '\0';
4817        exit(background_process(aTHX_ argc, argv));
4818         }
4819     /*
4820      * Now we handle the general redirection cases that involve '>', '>>',
4821      * '<', and pipes '|'.
4822      */
4823     for (j = 0; j < argc; ++j)
4824         {
4825         if (0 == strcmp("<", argv[j]))
4826             {
4827             if (j+1 >= argc)
4828                 {
4829                 fprintf(stderr,"No input file after < on command line");
4830                 exit(LIB$_WRONUMARG);
4831                 }
4832             in = argv[++j];
4833             continue;
4834             }
4835         if ('<' == *(ap = argv[j]))
4836             {
4837             in = 1 + ap;
4838             continue;
4839             }
4840         if (0 == strcmp(">", ap))
4841             {
4842             if (j+1 >= argc)
4843                 {
4844                 fprintf(stderr,"No output file after > on command line");
4845                 exit(LIB$_WRONUMARG);
4846                 }
4847             out = argv[++j];
4848             continue;
4849             }
4850         if ('>' == *ap)
4851             {
4852             if ('>' == ap[1])
4853                 {
4854                 outmode = "a";
4855                 if ('\0' == ap[2])
4856                     out = argv[++j];
4857                 else
4858                     out = 2 + ap;
4859                 }
4860             else
4861                 out = 1 + ap;
4862             if (j >= argc)
4863                 {
4864                 fprintf(stderr,"No output file after > or >> on command line");
4865                 exit(LIB$_WRONUMARG);
4866                 }
4867             continue;
4868             }
4869         if (('2' == *ap) && ('>' == ap[1]))
4870             {
4871             if ('>' == ap[2])
4872                 {
4873                 errmode = "a";
4874                 if ('\0' == ap[3])
4875                     err = argv[++j];
4876                 else
4877                     err = 3 + ap;
4878                 }
4879             else
4880                 if ('\0' == ap[2])
4881                     err = argv[++j];
4882                 else
4883                     err = 2 + ap;
4884             if (j >= argc)
4885                 {
4886                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4887                 exit(LIB$_WRONUMARG);
4888                 }
4889             continue;
4890             }
4891         if (0 == strcmp("|", argv[j]))
4892             {
4893             if (j+1 >= argc)
4894                 {
4895                 fprintf(stderr,"No command into which to pipe on command line");
4896                 exit(LIB$_WRONUMARG);
4897                 }
4898             cmargc = argc-(j+1);
4899             cmargv = &argv[j+1];
4900             argc = j;
4901             continue;
4902             }
4903         if ('|' == *(ap = argv[j]))
4904             {
4905             ++argv[j];
4906             cmargc = argc-j;
4907             cmargv = &argv[j];
4908             argc = j;
4909             continue;
4910             }
4911         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4912         }
4913     /*
4914      * Allocate and fill in the new argument vector, Some Unix's terminate
4915      * the list with an extra null pointer.
4916      */
4917     Newx(argv, item_count+1, char *);
4918     *av = argv;
4919     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4920         argv[j] = list_head->value;
4921     *ac = item_count;
4922     if (cmargv != NULL)
4923         {
4924         if (out != NULL)
4925             {
4926             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4927             exit(LIB$_INVARGORD);
4928             }
4929         pipe_and_fork(aTHX_ cmargv);
4930         }
4931
4932     /* Check for input from a pipe (mailbox) */
4933
4934     if (in == NULL && 1 == isapipe(0))
4935         {
4936         char mbxname[L_tmpnam];
4937         long int bufsize;
4938         long int dvi_item = DVI$_DEVBUFSIZ;
4939         $DESCRIPTOR(mbxnam, "");
4940         $DESCRIPTOR(mbxdevnam, "");
4941
4942         /* Input from a pipe, reopen it in binary mode to disable       */
4943         /* carriage control processing.                                 */
4944
4945         fgetname(stdin, mbxname);
4946         mbxnam.dsc$a_pointer = mbxname;
4947         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4948         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4949         mbxdevnam.dsc$a_pointer = mbxname;
4950         mbxdevnam.dsc$w_length = sizeof(mbxname);
4951         dvi_item = DVI$_DEVNAM;
4952         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4953         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4954         set_errno(0);
4955         set_vaxc_errno(1);
4956         freopen(mbxname, "rb", stdin);
4957         if (errno != 0)
4958             {
4959             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4960             exit(vaxc$errno);
4961             }
4962         }
4963     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4964         {
4965         fprintf(stderr,"Can't open input file %s as stdin",in);
4966         exit(vaxc$errno);
4967         }
4968     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4969         {
4970         fprintf(stderr,"Can't open output file %s as stdout",out);
4971         exit(vaxc$errno);
4972         }
4973         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4974
4975     if (err != NULL) {
4976         if (strcmp(err,"&1") == 0) {
4977             dup2(fileno(stdout), fileno(stderr));
4978             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4979         } else {
4980         FILE *tmperr;
4981         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4982             {
4983             fprintf(stderr,"Can't open error file %s as stderr",err);
4984             exit(vaxc$errno);
4985             }
4986             fclose(tmperr);
4987            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4988                 {
4989                 exit(vaxc$errno);
4990                 }
4991             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4992         }
4993         }
4994 #ifdef ARGPROC_DEBUG
4995     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4996     for (j = 0; j < *ac;  ++j)
4997         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4998 #endif
4999    /* Clear errors we may have hit expanding wildcards, so they don't
5000       show up in Perl's $! later */
5001    set_errno(0); set_vaxc_errno(1);
5002 }  /* end of getredirection() */
5003 /*}}}*/
5004
5005 static void add_item(struct list_item **head,
5006                      struct list_item **tail,
5007                      char *value,
5008                      int *count)
5009 {
5010     if (*head == 0)
5011         {
5012         Newx(*head,1,struct list_item);
5013         *tail = *head;
5014         }
5015     else {
5016         Newx((*tail)->next,1,struct list_item);
5017         *tail = (*tail)->next;
5018         }
5019     (*tail)->value = value;
5020     ++(*count);
5021 }
5022
5023 static void mp_expand_wild_cards(pTHX_ char *item,
5024                               struct list_item **head,
5025                               struct list_item **tail,
5026                               int *count)
5027 {
5028 int expcount = 0;
5029 unsigned long int context = 0;
5030 int isunix = 0;
5031 int item_len = 0;
5032 char *had_version;
5033 char *had_device;
5034 int had_directory;
5035 char *devdir,*cp;
5036 char vmsspec[NAM$C_MAXRSS+1];
5037 $DESCRIPTOR(filespec, "");
5038 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
5039 $DESCRIPTOR(resultspec, "");
5040 unsigned long int zero = 0, sts;
5041
5042     for (cp = item; *cp; cp++) {
5043         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
5044         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
5045     }
5046     if (!*cp || isspace(*cp))
5047         {
5048         add_item(head, tail, item, count);
5049         return;
5050         }
5051     else
5052         {
5053      /* "double quoted" wild card expressions pass as is */
5054      /* From DCL that means using e.g.:                  */
5055      /* perl program """perl.*"""                        */
5056      item_len = strlen(item);
5057      if ( '"' == *item && '"' == item[item_len-1] )
5058        {
5059        item++;
5060        item[item_len-2] = '\0';
5061        add_item(head, tail, item, count);
5062        return;
5063        }
5064      }
5065     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
5066     resultspec.dsc$b_class = DSC$K_CLASS_D;
5067     resultspec.dsc$a_pointer = NULL;
5068     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
5069       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
5070     if (!isunix || !filespec.dsc$a_pointer)
5071       filespec.dsc$a_pointer = item;
5072     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
5073     /*
5074      * Only return version specs, if the caller specified a version
5075      */
5076     had_version = strchr(item, ';');
5077     /*
5078      * Only return device and directory specs, if the caller specifed either.
5079      */
5080     had_device = strchr(item, ':');
5081     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
5082
5083     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
5084                                   &defaultspec, 0, 0, &zero))))
5085         {
5086         char *string;
5087         char *c;
5088
5089         Newx(string,resultspec.dsc$w_length+1,char);
5090         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
5091         string[resultspec.dsc$w_length] = '\0';
5092         if (NULL == had_version)
5093             *(strrchr(string, ';')) = '\0';
5094         if ((!had_directory) && (had_device == NULL))
5095             {
5096             if (NULL == (devdir = strrchr(string, ']')))
5097                 devdir = strrchr(string, '>');
5098             strcpy(string, devdir + 1);
5099             }
5100         /*
5101          * Be consistent with what the C RTL has already done to the rest of
5102          * the argv items and lowercase all of these names.
5103          */
5104         if (!decc_efs_case_preserve) {
5105             for (c = string; *c; ++c)
5106             if (isupper(*c))
5107                 *c = tolower(*c);
5108         }
5109         if (isunix) trim_unixpath(string,item,1);
5110         add_item(head, tail, string, count);
5111         ++expcount;
5112         }
5113     if (sts != RMS$_NMF)
5114         {
5115         set_vaxc_errno(sts);
5116         switch (sts)
5117             {
5118             case RMS$_FNF: case RMS$_DNF:
5119                 set_errno(ENOENT); break;
5120             case RMS$_DIR:
5121                 set_errno(ENOTDIR); break;
5122             case RMS$_DEV:
5123                 set_errno(ENODEV); break;
5124             case RMS$_FNM: case RMS$_SYN:
5125                 set_errno(EINVAL); break;
5126             case RMS$_PRV:
5127                 set_errno(EACCES); break;
5128             default:
5129                 _ckvmssts_noperl(sts);
5130             }
5131         }
5132     if (expcount == 0)
5133         add_item(head, tail, item, count);
5134     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
5135     _ckvmssts_noperl(lib$find_file_end(&context));
5136 }
5137
5138 static int child_st[2];/* Event Flag set when child process completes   */
5139
5140 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
5141
5142 static unsigned long int exit_handler(int *status)
5143 {
5144 short iosb[4];
5145
5146     if (0 == child_st[0])
5147         {
5148 #ifdef ARGPROC_DEBUG
5149         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
5150 #endif
5151         fflush(stdout);     /* Have to flush pipe for binary data to    */
5152                             /* terminate properly -- <tp@mccall.com>    */
5153         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
5154         sys$dassgn(child_chan);
5155         fclose(stdout);
5156         sys$synch(0, child_st);
5157         }
5158     return(1);
5159 }
5160
5161 static void sig_child(int chan)
5162 {
5163 #ifdef ARGPROC_DEBUG
5164     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
5165 #endif
5166     if (child_st[0] == 0)
5167         child_st[0] = 1;
5168 }
5169
5170 static struct exit_control_block exit_block =
5171     {
5172     0,
5173     exit_handler,
5174     1,
5175     &exit_block.exit_status,
5176     0
5177     };
5178
5179 static void
5180 pipe_and_fork(pTHX_ char **cmargv)
5181 {
5182     PerlIO *fp;
5183     struct dsc$descriptor_s *vmscmd;
5184     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
5185     int sts, j, l, ismcr, quote, tquote = 0;
5186
5187     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
5188     vms_execfree(vmscmd);
5189
5190     j = l = 0;
5191     p = subcmd;
5192     q = cmargv[0];
5193     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
5194               && toupper(*(q+2)) == 'R' && !*(q+3);
5195
5196     while (q && l < MAX_DCL_LINE_LENGTH) {
5197         if (!*q) {
5198             if (j > 0 && quote) {
5199                 *p++ = '"';
5200                 l++;
5201             }
5202             q = cmargv[++j];
5203             if (q) {
5204                 if (ismcr && j > 1) quote = 1;
5205                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
5206                 *p++ = ' ';
5207                 l++;
5208                 if (quote || tquote) {
5209                     *p++ = '"';
5210                     l++;
5211                 }
5212         }
5213         } else {
5214             if ((quote||tquote) && *q == '"') {
5215                 *p++ = '"';
5216                 l++;
5217         }
5218             *p++ = *q++;
5219             l++;
5220         }
5221     }
5222     *p = '\0';
5223
5224     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
5225     if (fp == Nullfp) {
5226         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
5227         }
5228 }
5229
5230 static int background_process(pTHX_ int argc, char **argv)
5231 {
5232 char command[2048] = "$";
5233 $DESCRIPTOR(value, "");
5234 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
5235 static $DESCRIPTOR(null, "NLA0:");
5236 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
5237 char pidstring[80];
5238 $DESCRIPTOR(pidstr, "");
5239 int pid;
5240 unsigned long int flags = 17, one = 1, retsts;
5241
5242     strcat(command, argv[0]);
5243     while (--argc)
5244         {
5245         strcat(command, " \"");
5246         strcat(command, *(++argv));
5247         strcat(command, "\"");
5248         }
5249     value.dsc$a_pointer = command;
5250     value.dsc$w_length = strlen(value.dsc$a_pointer);
5251     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
5252     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
5253     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
5254         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
5255     }
5256     else {
5257         _ckvmssts_noperl(retsts);
5258     }
5259 #ifdef ARGPROC_DEBUG
5260     PerlIO_printf(Perl_debug_log, "%s\n", command);
5261 #endif
5262     sprintf(pidstring, "%08X", pid);
5263     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
5264     pidstr.dsc$a_pointer = pidstring;
5265     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
5266     lib$set_symbol(&pidsymbol, &pidstr);
5267     return(SS$_NORMAL);
5268 }
5269 /*}}}*/
5270 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
5271
5272
5273 /* OS-specific initialization at image activation (not thread startup) */
5274 /* Older VAXC header files lack these constants */
5275 #ifndef JPI$_RIGHTS_SIZE
5276 #  define JPI$_RIGHTS_SIZE 817
5277 #endif
5278 #ifndef KGB$M_SUBSYSTEM
5279 #  define KGB$M_SUBSYSTEM 0x8
5280 #endif
5281
5282 /*{{{void vms_image_init(int *, char ***)*/
5283 void
5284 vms_image_init(int *argcp, char ***argvp)
5285 {
5286   char eqv[LNM$C_NAMLENGTH+1] = "";
5287   unsigned int len, tabct = 8, tabidx = 0;
5288   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
5289   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
5290   unsigned short int dummy, rlen;
5291   struct dsc$descriptor_s **tabvec;
5292 #if defined(PERL_IMPLICIT_CONTEXT)
5293   pTHX = NULL;
5294 #endif
5295   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
5296                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
5297                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
5298                                  {          0,                0,    0,      0} };
5299
5300 #ifdef KILL_BY_SIGPRC
5301     Perl_csighandler_init();
5302 #endif
5303
5304   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
5305   _ckvmssts_noperl(iosb[0]);
5306   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
5307     if (iprv[i]) {           /* Running image installed with privs? */
5308       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
5309       will_taint = TRUE;
5310       break;
5311     }
5312   }
5313   /* Rights identifiers might trigger tainting as well. */
5314   if (!will_taint && (rlen || rsz)) {
5315     while (rlen < rsz) {
5316       /* We didn't get all the identifiers on the first pass.  Allocate a
5317        * buffer much larger than $GETJPI wants (rsz is size in bytes that
5318        * were needed to hold all identifiers at time of last call; we'll
5319        * allocate that many unsigned long ints), and go back and get 'em.
5320        * If it gave us less than it wanted to despite ample buffer space,
5321        * something's broken.  Is your system missing a system identifier?
5322        */
5323       if (rsz <= jpilist[1].buflen) {
5324          /* Perl_croak accvios when used this early in startup. */
5325          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
5326                          rsz, (unsigned long) jpilist[1].buflen,
5327                          "Check your rights database for corruption.\n");
5328          exit(SS$_ABORT);
5329       }
5330       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
5331       jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
5332       jpilist[1].buflen = rsz * sizeof(unsigned long int);
5333       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
5334       _ckvmssts_noperl(iosb[0]);
5335     }
5336     mask = jpilist[1].bufadr;
5337     /* Check attribute flags for each identifier (2nd longword); protected
5338      * subsystem identifiers trigger tainting.
5339      */
5340     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
5341       if (mask[i] & KGB$M_SUBSYSTEM) {
5342         will_taint = TRUE;
5343         break;
5344       }
5345     }
5346     if (mask != rlst) Safefree(mask);
5347   }
5348
5349   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
5350    * logical, some versions of the CRTL will add a phanthom /000000/
5351    * directory.  This needs to be removed.
5352    */
5353   if (decc_filename_unix_report) {
5354   char * zeros;
5355   int ulen;
5356     ulen = strlen(argvp[0][0]);
5357     if (ulen > 7) {
5358       zeros = strstr(argvp[0][0], "/000000/");
5359       if (zeros != NULL) {
5360         int mlen;
5361         mlen = ulen - (zeros - argvp[0][0]) - 7;
5362         memmove(zeros, &zeros[7], mlen);
5363         ulen = ulen - 7;
5364         argvp[0][0][ulen] = '\0';
5365       }
5366     }
5367     /* It also may have a trailing dot that needs to be removed otherwise
5368      * it will be converted to VMS mode incorrectly.
5369      */
5370     ulen--;
5371     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
5372       argvp[0][0][ulen] = '\0';
5373   }
5374
5375   /* We need to use this hack to tell Perl it should run with tainting,
5376    * since its tainting flag may be part of the PL_curinterp struct, which
5377    * hasn't been allocated when vms_image_init() is called.
5378    */
5379   if (will_taint) {
5380     char **newargv, **oldargv;
5381     oldargv = *argvp;
5382     Newx(newargv,(*argcp)+2,char *);
5383     newargv[0] = oldargv[0];
5384     Newx(newargv[1],3,char);
5385     strcpy(newargv[1], "-T");
5386     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
5387     (*argcp)++;
5388     newargv[*argcp] = NULL;
5389     /* We orphan the old argv, since we don't know where it's come from,
5390      * so we don't know how to free it.
5391      */
5392     *argvp = newargv;
5393   }
5394   else {  /* Did user explicitly request tainting? */
5395     int i;
5396     char *cp, **av = *argvp;
5397     for (i = 1; i < *argcp; i++) {
5398       if (*av[i] != '-') break;
5399       for (cp = av[i]+1; *cp; cp++) {
5400         if (*cp == 'T') { will_taint = 1; break; }
5401         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
5402                   strchr("DFIiMmx",*cp)) break;
5403       }
5404       if (will_taint) break;
5405     }
5406   }
5407
5408   for (tabidx = 0;
5409        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
5410        tabidx++) {
5411     if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
5412     else if (tabidx >= tabct) {
5413       tabct += 8;
5414       Renew(tabvec,tabct,struct dsc$descriptor_s *);
5415     }
5416     Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
5417     tabvec[tabidx]->dsc$w_length  = 0;
5418     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
5419     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
5420     tabvec[tabidx]->dsc$a_pointer = NULL;
5421     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
5422   }
5423   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
5424
5425   getredirection(argcp,argvp);
5426 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
5427   {
5428 # include <reentrancy.h>
5429   decc$set_reentrancy(C$C_MULTITHREAD);
5430   }
5431 #endif
5432   return;
5433 }
5434 /*}}}*/
5435
5436
5437 /* trim_unixpath()
5438  * Trim Unix-style prefix off filespec, so it looks like what a shell
5439  * glob expansion would return (i.e. from specified prefix on, not
5440  * full path).  Note that returned filespec is Unix-style, regardless
5441  * of whether input filespec was VMS-style or Unix-style.
5442  *
5443  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
5444  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
5445  * vector of options; at present, only bit 0 is used, and if set tells
5446  * trim unixpath to try the current default directory as a prefix when
5447  * presented with a possibly ambiguous ... wildcard.
5448  *
5449  * Returns !=0 on success, with trimmed filespec replacing contents of
5450  * fspec, and 0 on failure, with contents of fpsec unchanged.
5451  */
5452 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
5453 int
5454 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
5455 {
5456   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
5457        *template, *base, *end, *cp1, *cp2;
5458   register int tmplen, reslen = 0, dirs = 0;
5459
5460   if (!wildspec || !fspec) return 0;
5461   template = unixwild;
5462   if (strpbrk(wildspec,"]>:") != NULL) {
5463     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
5464   }
5465   else {
5466     strncpy(unixwild, wildspec, NAM$C_MAXRSS);
5467     unixwild[NAM$C_MAXRSS] = 0;
5468   }
5469   if (strpbrk(fspec,"]>:") != NULL) {
5470     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
5471     else base = unixified;
5472     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
5473      * check to see that final result fits into (isn't longer than) fspec */
5474     reslen = strlen(fspec);
5475   }
5476   else base = fspec;
5477
5478   /* No prefix or absolute path on wildcard, so nothing to remove */
5479   if (!*template || *template == '/') {
5480     if (base == fspec) return 1;
5481     tmplen = strlen(unixified);
5482     if (tmplen > reslen) return 0;  /* not enough space */
5483     /* Copy unixified resultant, including trailing NUL */
5484     memmove(fspec,unixified,tmplen+1);
5485     return 1;
5486   }
5487
5488   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
5489   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
5490     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
5491     for (cp1 = end ;cp1 >= base; cp1--)
5492       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
5493         { cp1++; break; }
5494     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
5495     return 1;
5496   }
5497   else {
5498     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
5499     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
5500     int ells = 1, totells, segdirs, match;
5501     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
5502                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5503
5504     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
5505     totells = ells;
5506     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
5507     if (ellipsis == template && opts & 1) {
5508       /* Template begins with an ellipsis.  Since we can't tell how many
5509        * directory names at the front of the resultant to keep for an
5510        * arbitrary starting point, we arbitrarily choose the current
5511        * default directory as a starting point.  If it's there as a prefix,
5512        * clip it off.  If not, fall through and act as if the leading
5513        * ellipsis weren't there (i.e. return shortest possible path that
5514        * could match template).
5515        */
5516       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
5517       if (!decc_efs_case_preserve) {
5518         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5519           if (_tolower(*cp1) != _tolower(*cp2)) break;
5520       }
5521       segdirs = dirs - totells;  /* Min # of dirs we must have left */
5522       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
5523       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
5524         memcpy(fspec,cp2+1,end - cp2);
5525         return 1;
5526       }
5527     }
5528     /* First off, back up over constant elements at end of path */
5529     if (dirs) {
5530       for (front = end ; front >= base; front--)
5531          if (*front == '/' && !dirs--) { front++; break; }
5532     }
5533     if (!decc_efs_case_preserve) {
5534       for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
5535          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
5536     }
5537     if (cp1 != '\0') return 0;  /* Path too long. */
5538     lcend = cp2;
5539     *cp2 = '\0';  /* Pick up with memcpy later */
5540     lcfront = lcres + (front - base);
5541     /* Now skip over each ellipsis and try to match the path in front of it. */
5542     while (ells--) {
5543       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
5544         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
5545             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
5546       if (cp1 < template) break; /* template started with an ellipsis */
5547       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
5548         ellipsis = cp1; continue;
5549       }
5550       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
5551       nextell = cp1;
5552       for (segdirs = 0, cp2 = tpl;
5553            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
5554            cp1++, cp2++) {
5555          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
5556          else {
5557             if (!decc_efs_case_preserve) {
5558               *cp2 = _tolower(*cp1);  /* else lowercase for match */
5559             }
5560             else {
5561               *cp2 = *cp1;  /* else preserve case for match */
5562             }
5563          }
5564          if (*cp2 == '/') segdirs++;
5565       }
5566       if (cp1 != ellipsis - 1) return 0; /* Path too long */
5567       /* Back up at least as many dirs as in template before matching */
5568       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
5569         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
5570       for (match = 0; cp1 > lcres;) {
5571         resdsc.dsc$a_pointer = cp1;
5572         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
5573           match++;
5574           if (match == 1) lcfront = cp1;
5575         }
5576         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
5577       }
5578       if (!match) return 0;  /* Can't find prefix ??? */
5579       if (match > 1 && opts & 1) {
5580         /* This ... wildcard could cover more than one set of dirs (i.e.
5581          * a set of similar dir names is repeated).  If the template
5582          * contains more than 1 ..., upstream elements could resolve the
5583          * ambiguity, but it's not worth a full backtracking setup here.
5584          * As a quick heuristic, clip off the current default directory
5585          * if it's present to find the trimmed spec, else use the
5586          * shortest string that this ... could cover.
5587          */
5588         char def[NAM$C_MAXRSS+1], *st;
5589
5590         if (getcwd(def, sizeof def,0) == NULL) return 0;
5591         if (!decc_efs_case_preserve) {
5592           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5593             if (_tolower(*cp1) != _tolower(*cp2)) break;
5594         }
5595         segdirs = dirs - totells;  /* Min # of dirs we must have left */
5596         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
5597         if (*cp1 == '\0' && *cp2 == '/') {
5598           memcpy(fspec,cp2+1,end - cp2);
5599           return 1;
5600         }
5601         /* Nope -- stick with lcfront from above and keep going. */
5602       }
5603     }
5604     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
5605     return 1;
5606     ellipsis = nextell;
5607   }
5608
5609 }  /* end of trim_unixpath() */
5610 /*}}}*/
5611
5612
5613 /*
5614  *  VMS readdir() routines.
5615  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
5616  *
5617  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
5618  *  Minor modifications to original routines.
5619  */
5620
5621 /* readdir may have been redefined by reentr.h, so make sure we get
5622  * the local version for what we do here.
5623  */
5624 #ifdef readdir
5625 # undef readdir
5626 #endif
5627 #if !defined(PERL_IMPLICIT_CONTEXT)
5628 # define readdir Perl_readdir
5629 #else
5630 # define readdir(a) Perl_readdir(aTHX_ a)
5631 #endif
5632
5633     /* Number of elements in vms_versions array */
5634 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
5635
5636 /*
5637  *  Open a directory, return a handle for later use.
5638  */
5639 /*{{{ DIR *opendir(char*name) */
5640 DIR *
5641 Perl_opendir(pTHX_ const char *name)
5642 {
5643     DIR *dd;
5644     char dir[NAM$C_MAXRSS+1];
5645     Stat_t sb;
5646
5647     if (do_tovmspath(name,dir,0) == NULL) {
5648       return NULL;
5649     }
5650     /* Check access before stat; otherwise stat does not
5651      * accurately report whether it's a directory.
5652      */
5653     if (!cando_by_name(S_IRUSR,0,dir)) {
5654       /* cando_by_name has already set errno */
5655       return NULL;
5656     }
5657     if (flex_stat(dir,&sb) == -1) return NULL;
5658     if (!S_ISDIR(sb.st_mode)) {
5659       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
5660       return NULL;
5661     }
5662     /* Get memory for the handle, and the pattern. */
5663     Newx(dd,1,DIR);
5664     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
5665
5666     /* Fill in the fields; mainly playing with the descriptor. */
5667     sprintf(dd->pattern, "%s*.*",dir);
5668     dd->context = 0;
5669     dd->count = 0;
5670     dd->vms_wantversions = 0;
5671     dd->pat.dsc$a_pointer = dd->pattern;
5672     dd->pat.dsc$w_length = strlen(dd->pattern);
5673     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
5674     dd->pat.dsc$b_class = DSC$K_CLASS_S;
5675 #if defined(USE_ITHREADS)
5676     Newx(dd->mutex,1,perl_mutex);
5677     MUTEX_INIT( (perl_mutex *) dd->mutex );
5678 #else
5679     dd->mutex = NULL;
5680 #endif
5681
5682     return dd;
5683 }  /* end of opendir() */
5684 /*}}}*/
5685
5686 /*
5687  *  Set the flag to indicate we want versions or not.
5688  */
5689 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
5690 void
5691 vmsreaddirversions(DIR *dd, int flag)
5692 {
5693     dd->vms_wantversions = flag;
5694 }
5695 /*}}}*/
5696
5697 /*
5698  *  Free up an opened directory.
5699  */
5700 /*{{{ void closedir(DIR *dd)*/
5701 void
5702 closedir(DIR *dd)
5703 {
5704     int sts;
5705
5706     sts = lib$find_file_end(&dd->context);
5707     Safefree(dd->pattern);
5708 #if defined(USE_ITHREADS)
5709     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
5710     Safefree(dd->mutex);
5711 #endif
5712     Safefree(dd);
5713 }
5714 /*}}}*/
5715
5716 /*
5717  *  Collect all the version numbers for the current file.
5718  */
5719 static void
5720 collectversions(pTHX_ DIR *dd)
5721 {
5722     struct dsc$descriptor_s     pat;
5723     struct dsc$descriptor_s     res;
5724     struct dirent *e;
5725     char *p, *text, buff[sizeof dd->entry.d_name];
5726     int i;
5727     unsigned long context, tmpsts;
5728
5729     /* Convenient shorthand. */
5730     e = &dd->entry;
5731
5732     /* Add the version wildcard, ignoring the "*.*" put on before */
5733     i = strlen(dd->pattern);
5734     Newx(text,i + e->d_namlen + 3,char);
5735     strcpy(text, dd->pattern);
5736     sprintf(&text[i - 3], "%s;*", e->d_name);
5737
5738     /* Set up the pattern descriptor. */
5739     pat.dsc$a_pointer = text;
5740     pat.dsc$w_length = i + e->d_namlen - 1;
5741     pat.dsc$b_dtype = DSC$K_DTYPE_T;
5742     pat.dsc$b_class = DSC$K_CLASS_S;
5743
5744     /* Set up result descriptor. */
5745     res.dsc$a_pointer = buff;
5746     res.dsc$w_length = sizeof buff - 2;
5747     res.dsc$b_dtype = DSC$K_DTYPE_T;
5748     res.dsc$b_class = DSC$K_CLASS_S;
5749
5750     /* Read files, collecting versions. */
5751     for (context = 0, e->vms_verscount = 0;
5752          e->vms_verscount < VERSIZE(e);
5753          e->vms_verscount++) {
5754         tmpsts = lib$find_file(&pat, &res, &context);
5755         if (tmpsts == RMS$_NMF || context == 0) break;
5756         _ckvmssts(tmpsts);
5757         buff[sizeof buff - 1] = '\0';
5758         if ((p = strchr(buff, ';')))
5759             e->vms_versions[e->vms_verscount] = atoi(p + 1);
5760         else
5761             e->vms_versions[e->vms_verscount] = -1;
5762     }
5763
5764     _ckvmssts(lib$find_file_end(&context));
5765     Safefree(text);
5766
5767 }  /* end of collectversions() */
5768
5769 /*
5770  *  Read the next entry from the directory.
5771  */
5772 /*{{{ struct dirent *readdir(DIR *dd)*/
5773 struct dirent *
5774 Perl_readdir(pTHX_ DIR *dd)
5775 {
5776     struct dsc$descriptor_s     res;
5777     char *p, buff[sizeof dd->entry.d_name];
5778     unsigned long int tmpsts;
5779
5780     /* Set up result descriptor, and get next file. */
5781     res.dsc$a_pointer = buff;
5782     res.dsc$w_length = sizeof buff - 2;
5783     res.dsc$b_dtype = DSC$K_DTYPE_T;
5784     res.dsc$b_class = DSC$K_CLASS_S;
5785     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5786     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
5787     if (!(tmpsts & 1)) {
5788       set_vaxc_errno(tmpsts);
5789       switch (tmpsts) {
5790         case RMS$_PRV:
5791           set_errno(EACCES); break;
5792         case RMS$_DEV:
5793           set_errno(ENODEV); break;
5794         case RMS$_DIR:
5795           set_errno(ENOTDIR); break;
5796         case RMS$_FNF: case RMS$_DNF:
5797           set_errno(ENOENT); break;
5798         default:
5799           set_errno(EVMSERR);
5800       }
5801       return NULL;
5802     }
5803     dd->count++;
5804     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5805     if (!decc_efs_case_preserve) {
5806       buff[sizeof buff - 1] = '\0';
5807       for (p = buff; *p; p++) *p = _tolower(*p);
5808       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5809       *p = '\0';
5810     }
5811     else {
5812       /* we don't want to force to lowercase, just null terminate */
5813       buff[res.dsc$w_length] = '\0';
5814     }
5815     for (p = buff; *p; p++) *p = _tolower(*p);
5816     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
5817     *p = '\0';
5818
5819     /* Skip any directory component and just copy the name. */
5820     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
5821     else strcpy(dd->entry.d_name, buff);
5822
5823     /* Clobber the version. */
5824     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5825
5826     dd->entry.d_namlen = strlen(dd->entry.d_name);
5827     dd->entry.vms_verscount = 0;
5828     if (dd->vms_wantversions) collectversions(aTHX_ dd);
5829     return &dd->entry;
5830
5831 }  /* end of readdir() */
5832 /*}}}*/
5833
5834 /*
5835  *  Read the next entry from the directory -- thread-safe version.
5836  */
5837 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5838 int
5839 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5840 {
5841     int retval;
5842
5843     MUTEX_LOCK( (perl_mutex *) dd->mutex );
5844
5845     entry = readdir(dd);
5846     *result = entry;
5847     retval = ( *result == NULL ? errno : 0 );
5848
5849     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5850
5851     return retval;
5852
5853 }  /* end of readdir_r() */
5854 /*}}}*/
5855
5856 /*
5857  *  Return something that can be used in a seekdir later.
5858  */
5859 /*{{{ long telldir(DIR *dd)*/
5860 long
5861 telldir(DIR *dd)
5862 {
5863     return dd->count;
5864 }
5865 /*}}}*/
5866
5867 /*
5868  *  Return to a spot where we used to be.  Brute force.
5869  */
5870 /*{{{ void seekdir(DIR *dd,long count)*/
5871 void
5872 Perl_seekdir(pTHX_ DIR *dd, long count)
5873 {
5874     int vms_wantversions;
5875
5876     /* If we haven't done anything yet... */
5877     if (dd->count == 0)
5878         return;
5879
5880     /* Remember some state, and clear it. */
5881     vms_wantversions = dd->vms_wantversions;
5882     dd->vms_wantversions = 0;
5883     _ckvmssts(lib$find_file_end(&dd->context));
5884     dd->context = 0;
5885
5886     /* The increment is in readdir(). */
5887     for (dd->count = 0; dd->count < count; )
5888         readdir(dd);
5889
5890     dd->vms_wantversions = vms_wantversions;
5891
5892 }  /* end of seekdir() */
5893 /*}}}*/
5894
5895 /* VMS subprocess management
5896  *
5897  * my_vfork() - just a vfork(), after setting a flag to record that
5898  * the current script is trying a Unix-style fork/exec.
5899  *
5900  * vms_do_aexec() and vms_do_exec() are called in response to the
5901  * perl 'exec' function.  If this follows a vfork call, then they
5902  * call out the regular perl routines in doio.c which do an
5903  * execvp (for those who really want to try this under VMS).
5904  * Otherwise, they do exactly what the perl docs say exec should
5905  * do - terminate the current script and invoke a new command
5906  * (See below for notes on command syntax.)
5907  *
5908  * do_aspawn() and do_spawn() implement the VMS side of the perl
5909  * 'system' function.
5910  *
5911  * Note on command arguments to perl 'exec' and 'system': When handled
5912  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5913  * are concatenated to form a DCL command string.  If the first arg
5914  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5915  * the command string is handed off to DCL directly.  Otherwise,
5916  * the first token of the command is taken as the filespec of an image
5917  * to run.  The filespec is expanded using a default type of '.EXE' and
5918  * the process defaults for device, directory, etc., and if found, the resultant
5919  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5920  * the command string as parameters.  This is perhaps a bit complicated,
5921  * but I hope it will form a happy medium between what VMS folks expect
5922  * from lib$spawn and what Unix folks expect from exec.
5923  */
5924
5925 static int vfork_called;
5926
5927 /*{{{int my_vfork()*/
5928 int
5929 my_vfork()
5930 {
5931   vfork_called++;
5932   return vfork();
5933 }
5934 /*}}}*/
5935
5936
5937 static void
5938 vms_execfree(struct dsc$descriptor_s *vmscmd)
5939 {
5940   if (vmscmd) {
5941       if (vmscmd->dsc$a_pointer) {
5942           Safefree(vmscmd->dsc$a_pointer);
5943       }
5944       Safefree(vmscmd);
5945   }
5946 }
5947
5948 static char *
5949 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5950 {
5951   char *junk, *tmps = Nullch;
5952   register size_t cmdlen = 0;
5953   size_t rlen;
5954   register SV **idx;
5955   STRLEN n_a;
5956
5957   idx = mark;
5958   if (really) {
5959     tmps = SvPV(really,rlen);
5960     if (*tmps) {
5961       cmdlen += rlen + 1;
5962       idx++;
5963     }
5964   }
5965
5966   for (idx++; idx <= sp; idx++) {
5967     if (*idx) {
5968       junk = SvPVx(*idx,rlen);
5969       cmdlen += rlen ? rlen + 1 : 0;
5970     }
5971   }
5972   Newx(PL_Cmd,cmdlen+1,char);
5973
5974   if (tmps && *tmps) {
5975     strcpy(PL_Cmd,tmps);
5976     mark++;
5977   }
5978   else *PL_Cmd = '\0';
5979   while (++mark <= sp) {
5980     if (*mark) {
5981       char *s = SvPVx(*mark,n_a);
5982       if (!*s) continue;
5983       if (*PL_Cmd) strcat(PL_Cmd," ");
5984       strcat(PL_Cmd,s);
5985     }
5986   }
5987   return PL_Cmd;
5988
5989 }  /* end of setup_argstr() */
5990
5991
5992 static unsigned long int
5993 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
5994                    struct dsc$descriptor_s **pvmscmd)
5995 {
5996   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5997   $DESCRIPTOR(defdsc,".EXE");
5998   $DESCRIPTOR(defdsc2,".");
5999   $DESCRIPTOR(resdsc,resspec);
6000   struct dsc$descriptor_s *vmscmd;
6001   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6002   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
6003   register char *s, *rest, *cp, *wordbreak;
6004   char * cmd;
6005   int cmdlen;
6006   register int isdcl;
6007
6008   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
6009
6010   /* Make a copy for modification */
6011   cmdlen = strlen(incmd);
6012   Newx(cmd, cmdlen+1, char);
6013   strncpy(cmd, incmd, cmdlen);
6014   cmd[cmdlen] = 0;
6015
6016   vmscmd->dsc$a_pointer = NULL;
6017   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
6018   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
6019   vmscmd->dsc$w_length = 0;
6020   if (pvmscmd) *pvmscmd = vmscmd;
6021
6022   if (suggest_quote) *suggest_quote = 0;
6023
6024   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
6025     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
6026     Safefree(cmd);
6027   }
6028
6029   s = cmd;
6030
6031   while (*s && isspace(*s)) s++;
6032
6033   if (*s == '@' || *s == '$') {
6034     vmsspec[0] = *s;  rest = s + 1;
6035     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
6036   }
6037   else { cp = vmsspec; rest = s; }
6038   if (*rest == '.' || *rest == '/') {
6039     char *cp2;
6040     for (cp2 = resspec;
6041          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
6042          rest++, cp2++) *cp2 = *rest;
6043     *cp2 = '\0';
6044     if (do_tovmsspec(resspec,cp,0)) {
6045       s = vmsspec;
6046       if (*rest) {
6047         for (cp2 = vmsspec + strlen(vmsspec);
6048              *rest && cp2 - vmsspec < sizeof vmsspec;
6049              rest++, cp2++) *cp2 = *rest;
6050         *cp2 = '\0';
6051       }
6052     }
6053   }
6054   /* Intuit whether verb (first word of cmd) is a DCL command:
6055    *   - if first nonspace char is '@', it's a DCL indirection
6056    * otherwise
6057    *   - if verb contains a filespec separator, it's not a DCL command
6058    *   - if it doesn't, caller tells us whether to default to a DCL
6059    *     command, or to a local image unless told it's DCL (by leading '$')
6060    */
6061   if (*s == '@') {
6062       isdcl = 1;
6063       if (suggest_quote) *suggest_quote = 1;
6064   } else {
6065     register char *filespec = strpbrk(s,":<[.;");
6066     rest = wordbreak = strpbrk(s," \"\t/");
6067     if (!wordbreak) wordbreak = s + strlen(s);
6068     if (*s == '$') check_img = 0;
6069     if (filespec && (filespec < wordbreak)) isdcl = 0;
6070     else isdcl = !check_img;
6071   }
6072
6073   if (!isdcl) {
6074     imgdsc.dsc$a_pointer = s;
6075     imgdsc.dsc$w_length = wordbreak - s;
6076     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6077     if (!(retsts&1)) {
6078         _ckvmssts(lib$find_file_end(&cxt));
6079         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6080     if (!(retsts & 1) && *s == '$') {
6081           _ckvmssts(lib$find_file_end(&cxt));
6082       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
6083       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6084           if (!(retsts&1)) {
6085       _ckvmssts(lib$find_file_end(&cxt));
6086             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6087           }
6088     }
6089     }
6090     _ckvmssts(lib$find_file_end(&cxt));
6091
6092     if (retsts & 1) {
6093       FILE *fp;
6094       s = resspec;
6095       while (*s && !isspace(*s)) s++;
6096       *s = '\0';
6097
6098       /* check that it's really not DCL with no file extension */
6099       fp = fopen(resspec,"r","ctx=bin","shr=get");
6100       if (fp) {
6101         char b[4] = {0,0,0,0};
6102         read(fileno(fp),b,4);
6103         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
6104         fclose(fp);
6105       }
6106       if (check_img && isdcl) return RMS$_FNF;
6107
6108       if (cando_by_name(S_IXUSR,0,resspec)) {
6109         Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
6110         if (!isdcl) {
6111             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
6112             if (suggest_quote) *suggest_quote = 1;
6113         } else {
6114             strcpy(vmscmd->dsc$a_pointer,"@");
6115             if (suggest_quote) *suggest_quote = 1;
6116         }
6117         strcat(vmscmd->dsc$a_pointer,resspec);
6118         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
6119         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
6120         Safefree(cmd);
6121         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6122       }
6123       else retsts = RMS$_PRV;
6124     }
6125   }
6126   /* It's either a DCL command or we couldn't find a suitable image */
6127   vmscmd->dsc$w_length = strlen(cmd);
6128 /*  if (cmd == PL_Cmd) {
6129       vmscmd->dsc$a_pointer = PL_Cmd;
6130       if (suggest_quote) *suggest_quote = 1;
6131   }
6132   else  */
6133       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
6134
6135   Safefree(cmd);
6136
6137   /* check if it's a symbol (for quoting purposes) */
6138   if (suggest_quote && !*suggest_quote) {
6139     int iss;
6140     char equiv[LNM$C_NAMLENGTH];
6141     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6142     eqvdsc.dsc$a_pointer = equiv;
6143
6144     iss = lib$get_symbol(vmscmd,&eqvdsc);
6145     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
6146   }
6147   if (!(retsts & 1)) {
6148     /* just hand off status values likely to be due to user error */
6149     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
6150         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
6151        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
6152     else { _ckvmssts(retsts); }
6153   }
6154
6155   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6156
6157 }  /* end of setup_cmddsc() */
6158
6159
6160 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
6161 bool
6162 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
6163 {
6164   if (sp > mark) {
6165     if (vfork_called) {           /* this follows a vfork - act Unixish */
6166       vfork_called--;
6167       if (vfork_called < 0) {
6168         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6169         vfork_called = 0;
6170       }
6171       else return do_aexec(really,mark,sp);
6172     }
6173                                            /* no vfork - act VMSish */
6174     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
6175
6176   }
6177
6178   return FALSE;
6179 }  /* end of vms_do_aexec() */
6180 /*}}}*/
6181
6182 /* {{{bool vms_do_exec(char *cmd) */
6183 bool
6184 Perl_vms_do_exec(pTHX_ const char *cmd)
6185 {
6186   struct dsc$descriptor_s *vmscmd;
6187
6188   if (vfork_called) {             /* this follows a vfork - act Unixish */
6189     vfork_called--;
6190     if (vfork_called < 0) {
6191       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6192       vfork_called = 0;
6193     }
6194     else return do_exec(cmd);
6195   }
6196
6197   {                               /* no vfork - act VMSish */
6198     unsigned long int retsts;
6199
6200     TAINT_ENV();
6201     TAINT_PROPER("exec");
6202     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
6203       retsts = lib$do_command(vmscmd);
6204
6205     switch (retsts) {
6206       case RMS$_FNF: case RMS$_DNF:
6207         set_errno(ENOENT); break;
6208       case RMS$_DIR:
6209         set_errno(ENOTDIR); break;
6210       case RMS$_DEV:
6211         set_errno(ENODEV); break;
6212       case RMS$_PRV:
6213         set_errno(EACCES); break;
6214       case RMS$_SYN:
6215         set_errno(EINVAL); break;
6216       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6217         set_errno(E2BIG); break;
6218       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6219         _ckvmssts(retsts); /* fall through */
6220       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6221         set_errno(EVMSERR);
6222     }
6223     set_vaxc_errno(retsts);
6224     if (ckWARN(WARN_EXEC)) {
6225       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
6226              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
6227     }
6228     vms_execfree(vmscmd);
6229   }
6230
6231   return FALSE;
6232
6233 }  /* end of vms_do_exec() */
6234 /*}}}*/
6235
6236 unsigned long int Perl_do_spawn(pTHX_ const char *);
6237
6238 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
6239 unsigned long int
6240 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
6241 {
6242   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
6243
6244   return SS$_ABORT;
6245 }  /* end of do_aspawn() */
6246 /*}}}*/
6247
6248 /* {{{unsigned long int do_spawn(char *cmd) */
6249 unsigned long int
6250 Perl_do_spawn(pTHX_ const char *cmd)
6251 {
6252   unsigned long int sts, substs;
6253
6254   TAINT_ENV();
6255   TAINT_PROPER("spawn");
6256   if (!cmd || !*cmd) {
6257     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
6258     if (!(sts & 1)) {
6259       switch (sts) {
6260         case RMS$_FNF:  case RMS$_DNF:
6261           set_errno(ENOENT); break;
6262         case RMS$_DIR:
6263           set_errno(ENOTDIR); break;
6264         case RMS$_DEV:
6265           set_errno(ENODEV); break;
6266         case RMS$_PRV:
6267           set_errno(EACCES); break;
6268         case RMS$_SYN:
6269           set_errno(EINVAL); break;
6270         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6271           set_errno(E2BIG); break;
6272         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6273           _ckvmssts(sts); /* fall through */
6274         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6275           set_errno(EVMSERR);
6276       }
6277       set_vaxc_errno(sts);
6278       if (ckWARN(WARN_EXEC)) {
6279         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
6280                     Strerror(errno));
6281       }
6282     }
6283     sts = substs;
6284   }
6285   else {
6286     PerlIO * fp;
6287     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
6288     if (fp != NULL)
6289       my_pclose(fp);
6290   }
6291   return sts;
6292 }  /* end of do_spawn() */
6293 /*}}}*/
6294
6295
6296 static unsigned int *sockflags, sockflagsize;
6297
6298 /*
6299  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
6300  * routines found in some versions of the CRTL can't deal with sockets.
6301  * We don't shim the other file open routines since a socket isn't
6302  * likely to be opened by a name.
6303  */
6304 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
6305 FILE *my_fdopen(int fd, const char *mode)
6306 {
6307   FILE *fp = fdopen(fd, mode);
6308
6309   if (fp) {
6310     unsigned int fdoff = fd / sizeof(unsigned int);
6311     struct stat sbuf; /* native stat; we don't need flex_stat */
6312     if (!sockflagsize || fdoff > sockflagsize) {
6313       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
6314       else           Newx  (sockflags,fdoff+2,unsigned int);
6315       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
6316       sockflagsize = fdoff + 2;
6317     }
6318     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
6319       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
6320   }
6321   return fp;
6322
6323 }
6324 /*}}}*/
6325
6326
6327 /*
6328  * Clear the corresponding bit when the (possibly) socket stream is closed.
6329  * There still a small hole: we miss an implicit close which might occur
6330  * via freopen().  >> Todo
6331  */
6332 /*{{{ int my_fclose(FILE *fp)*/
6333 int my_fclose(FILE *fp) {
6334   if (fp) {
6335     unsigned int fd = fileno(fp);
6336     unsigned int fdoff = fd / sizeof(unsigned int);
6337
6338     if (sockflagsize && fdoff <= sockflagsize)
6339       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
6340   }
6341   return fclose(fp);
6342 }
6343 /*}}}*/
6344
6345
6346 /*
6347  * A simple fwrite replacement which outputs itmsz*nitm chars without
6348  * introducing record boundaries every itmsz chars.
6349  * We are using fputs, which depends on a terminating null.  We may
6350  * well be writing binary data, so we need to accommodate not only
6351  * data with nulls sprinkled in the middle but also data with no null
6352  * byte at the end.
6353  */
6354 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
6355 int
6356 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
6357 {
6358   register char *cp, *end, *cpd, *data;
6359   register unsigned int fd = fileno(dest);
6360   register unsigned int fdoff = fd / sizeof(unsigned int);
6361   int retval;
6362   int bufsize = itmsz * nitm + 1;
6363
6364   if (fdoff < sockflagsize &&
6365       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
6366     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
6367     return nitm;
6368   }
6369
6370   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
6371   memcpy( data, src, itmsz*nitm );
6372   data[itmsz*nitm] = '\0';
6373
6374   end = data + itmsz * nitm;
6375   retval = (int) nitm; /* on success return # items written */
6376
6377   cpd = data;
6378   while (cpd <= end) {
6379     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
6380     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
6381     if (cp < end)
6382       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
6383     cpd = cp + 1;
6384   }
6385
6386   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
6387   return retval;
6388
6389 }  /* end of my_fwrite() */
6390 /*}}}*/
6391
6392 /*{{{ int my_flush(FILE *fp)*/
6393 int
6394 Perl_my_flush(pTHX_ FILE *fp)
6395 {
6396     int res;
6397     if ((res = fflush(fp)) == 0 && fp) {
6398 #ifdef VMS_DO_SOCKETS
6399         Stat_t s;
6400         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
6401 #endif
6402             res = fsync(fileno(fp));
6403     }
6404 /*
6405  * If the flush succeeded but set end-of-file, we need to clear
6406  * the error because our caller may check ferror().  BTW, this
6407  * probably means we just flushed an empty file.
6408  */
6409     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
6410
6411     return res;
6412 }
6413 /*}}}*/
6414
6415 /*
6416  * Here are replacements for the following Unix routines in the VMS environment:
6417  *      getpwuid    Get information for a particular UIC or UID
6418  *      getpwnam    Get information for a named user
6419  *      getpwent    Get information for each user in the rights database
6420  *      setpwent    Reset search to the start of the rights database
6421  *      endpwent    Finish searching for users in the rights database
6422  *
6423  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
6424  * (defined in pwd.h), which contains the following fields:-
6425  *      struct passwd {
6426  *              char        *pw_name;    Username (in lower case)
6427  *              char        *pw_passwd;  Hashed password
6428  *              unsigned int pw_uid;     UIC
6429  *              unsigned int pw_gid;     UIC group  number
6430  *              char        *pw_unixdir; Default device/directory (VMS-style)
6431  *              char        *pw_gecos;   Owner name
6432  *              char        *pw_dir;     Default device/directory (Unix-style)
6433  *              char        *pw_shell;   Default CLI name (eg. DCL)
6434  *      };
6435  * If the specified user does not exist, getpwuid and getpwnam return NULL.
6436  *
6437  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
6438  * not the UIC member number (eg. what's returned by getuid()),
6439  * getpwuid() can accept either as input (if uid is specified, the caller's
6440  * UIC group is used), though it won't recognise gid=0.
6441  *
6442  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
6443  * information about other users in your group or in other groups, respectively.
6444  * If the required privilege is not available, then these routines fill only
6445  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
6446  * string).
6447  *
6448  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
6449  */
6450
6451 /* sizes of various UAF record fields */
6452 #define UAI$S_USERNAME 12
6453 #define UAI$S_IDENT    31
6454 #define UAI$S_OWNER    31
6455 #define UAI$S_DEFDEV   31
6456 #define UAI$S_DEFDIR   63
6457 #define UAI$S_DEFCLI   31
6458 #define UAI$S_PWD       8
6459
6460 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
6461                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
6462                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
6463
6464 static char __empty[]= "";
6465 static struct passwd __passwd_empty=
6466     {(char *) __empty, (char *) __empty, 0, 0,
6467      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
6468 static int contxt= 0;
6469 static struct passwd __pwdcache;
6470 static char __pw_namecache[UAI$S_IDENT+1];
6471
6472 /*
6473  * This routine does most of the work extracting the user information.
6474  */
6475 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
6476 {
6477     static struct {
6478         unsigned char length;
6479         char pw_gecos[UAI$S_OWNER+1];
6480     } owner;
6481     static union uicdef uic;
6482     static struct {
6483         unsigned char length;
6484         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
6485     } defdev;
6486     static struct {
6487         unsigned char length;
6488         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
6489     } defdir;
6490     static struct {
6491         unsigned char length;
6492         char pw_shell[UAI$S_DEFCLI+1];
6493     } defcli;
6494     static char pw_passwd[UAI$S_PWD+1];
6495
6496     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
6497     struct dsc$descriptor_s name_desc;
6498     unsigned long int sts;
6499
6500     static struct itmlst_3 itmlst[]= {
6501         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
6502         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
6503         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
6504         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
6505         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
6506         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
6507         {0,                0,           NULL,    NULL}};
6508
6509     name_desc.dsc$w_length=  strlen(name);
6510     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
6511     name_desc.dsc$b_class=   DSC$K_CLASS_S;
6512     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
6513
6514 /*  Note that sys$getuai returns many fields as counted strings. */
6515     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
6516     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
6517       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
6518     }
6519     else { _ckvmssts(sts); }
6520     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
6521
6522     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
6523     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
6524     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
6525     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
6526     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
6527     owner.pw_gecos[lowner]=            '\0';
6528     defdev.pw_dir[ldefdev+ldefdir]= '\0';
6529     defcli.pw_shell[ldefcli]=          '\0';
6530     if (valid_uic(uic)) {
6531         pwd->pw_uid= uic.uic$l_uic;
6532         pwd->pw_gid= uic.uic$v_group;
6533     }
6534     else
6535       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
6536     pwd->pw_passwd=  pw_passwd;
6537     pwd->pw_gecos=   owner.pw_gecos;
6538     pwd->pw_dir=     defdev.pw_dir;
6539     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
6540     pwd->pw_shell=   defcli.pw_shell;
6541     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
6542         int ldir;
6543         ldir= strlen(pwd->pw_unixdir) - 1;
6544         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
6545     }
6546     else
6547         strcpy(pwd->pw_unixdir, pwd->pw_dir);
6548     if (!decc_efs_case_preserve)
6549         __mystrtolower(pwd->pw_unixdir);
6550     return 1;
6551 }
6552
6553 /*
6554  * Get information for a named user.
6555 */
6556 /*{{{struct passwd *getpwnam(char *name)*/
6557 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
6558 {
6559     struct dsc$descriptor_s name_desc;
6560     union uicdef uic;
6561     unsigned long int status, sts;
6562
6563     __pwdcache = __passwd_empty;
6564     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
6565       /* We still may be able to determine pw_uid and pw_gid */
6566       name_desc.dsc$w_length=  strlen(name);
6567       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
6568       name_desc.dsc$b_class=   DSC$K_CLASS_S;
6569       name_desc.dsc$a_pointer= (char *) name;
6570       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
6571         __pwdcache.pw_uid= uic.uic$l_uic;
6572         __pwdcache.pw_gid= uic.uic$v_group;
6573       }
6574       else {
6575         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
6576           set_vaxc_errno(sts);
6577           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
6578           return NULL;
6579         }
6580         else { _ckvmssts(sts); }
6581       }
6582     }
6583     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
6584     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
6585     __pwdcache.pw_name= __pw_namecache;
6586     return &__pwdcache;
6587 }  /* end of my_getpwnam() */
6588 /*}}}*/
6589
6590 /*
6591  * Get information for a particular UIC or UID.
6592  * Called by my_getpwent with uid=-1 to list all users.
6593 */
6594 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
6595 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
6596 {
6597     const $DESCRIPTOR(name_desc,__pw_namecache);
6598     unsigned short lname;
6599     union uicdef uic;
6600     unsigned long int status;
6601
6602     if (uid == (unsigned int) -1) {
6603       do {
6604         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
6605         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
6606           set_vaxc_errno(status);
6607           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6608           my_endpwent();
6609           return NULL;
6610         }
6611         else { _ckvmssts(status); }
6612       } while (!valid_uic (uic));
6613     }
6614     else {
6615       uic.uic$l_uic= uid;
6616       if (!uic.uic$v_group)
6617         uic.uic$v_group= PerlProc_getgid();
6618       if (valid_uic(uic))
6619         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
6620       else status = SS$_IVIDENT;
6621       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
6622           status == RMS$_PRV) {
6623         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6624         return NULL;
6625       }
6626       else { _ckvmssts(status); }
6627     }
6628     __pw_namecache[lname]= '\0';
6629     __mystrtolower(__pw_namecache);
6630
6631     __pwdcache = __passwd_empty;
6632     __pwdcache.pw_name = __pw_namecache;
6633
6634 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
6635     The identifier's value is usually the UIC, but it doesn't have to be,
6636     so if we can, we let fillpasswd update this. */
6637     __pwdcache.pw_uid =  uic.uic$l_uic;
6638     __pwdcache.pw_gid =  uic.uic$v_group;
6639
6640     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
6641     return &__pwdcache;
6642
6643 }  /* end of my_getpwuid() */
6644 /*}}}*/
6645
6646 /*
6647  * Get information for next user.
6648 */
6649 /*{{{struct passwd *my_getpwent()*/
6650 struct passwd *Perl_my_getpwent(pTHX)
6651 {
6652     return (my_getpwuid((unsigned int) -1));
6653 }
6654 /*}}}*/
6655
6656 /*
6657  * Finish searching rights database for users.
6658 */
6659 /*{{{void my_endpwent()*/
6660 void Perl_my_endpwent(pTHX)
6661 {
6662     if (contxt) {
6663       _ckvmssts(sys$finish_rdb(&contxt));
6664       contxt= 0;
6665     }
6666 }
6667 /*}}}*/
6668
6669 #ifdef HOMEGROWN_POSIX_SIGNALS
6670   /* Signal handling routines, pulled into the core from POSIX.xs.
6671    *
6672    * We need these for threads, so they've been rolled into the core,
6673    * rather than left in POSIX.xs.
6674    *
6675    * (DRS, Oct 23, 1997)
6676    */
6677
6678   /* sigset_t is atomic under VMS, so these routines are easy */
6679 /*{{{int my_sigemptyset(sigset_t *) */
6680 int my_sigemptyset(sigset_t *set) {
6681     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6682     *set = 0; return 0;
6683 }
6684 /*}}}*/
6685
6686
6687 /*{{{int my_sigfillset(sigset_t *)*/
6688 int my_sigfillset(sigset_t *set) {
6689     int i;
6690     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6691     for (i = 0; i < NSIG; i++) *set |= (1 << i);
6692     return 0;
6693 }
6694 /*}}}*/
6695
6696
6697 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
6698 int my_sigaddset(sigset_t *set, int sig) {
6699     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6700     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6701     *set |= (1 << (sig - 1));
6702     return 0;
6703 }
6704 /*}}}*/
6705
6706
6707 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
6708 int my_sigdelset(sigset_t *set, int sig) {
6709     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6710     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6711     *set &= ~(1 << (sig - 1));
6712     return 0;
6713 }
6714 /*}}}*/
6715
6716
6717 /*{{{int my_sigismember(sigset_t *set, int sig)*/
6718 int my_sigismember(sigset_t *set, int sig) {
6719     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6720     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6721     return *set & (1 << (sig - 1));
6722 }
6723 /*}}}*/
6724
6725
6726 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
6727 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
6728     sigset_t tempmask;
6729
6730     /* If set and oset are both null, then things are badly wrong. Bail out. */
6731     if ((oset == NULL) && (set == NULL)) {
6732       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
6733       return -1;
6734     }
6735
6736     /* If set's null, then we're just handling a fetch. */
6737     if (set == NULL) {
6738         tempmask = sigblock(0);
6739     }
6740     else {
6741       switch (how) {
6742       case SIG_SETMASK:
6743         tempmask = sigsetmask(*set);
6744         break;
6745       case SIG_BLOCK:
6746         tempmask = sigblock(*set);
6747         break;
6748       case SIG_UNBLOCK:
6749         tempmask = sigblock(0);
6750         sigsetmask(*oset & ~tempmask);
6751         break;
6752       default:
6753         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6754         return -1;
6755       }
6756     }
6757
6758     /* Did they pass us an oset? If so, stick our holding mask into it */
6759     if (oset)
6760       *oset = tempmask;
6761
6762     return 0;
6763 }
6764 /*}}}*/
6765 #endif  /* HOMEGROWN_POSIX_SIGNALS */
6766
6767
6768 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
6769  * my_utime(), and flex_stat(), all of which operate on UTC unless
6770  * VMSISH_TIMES is true.
6771  */
6772 /* method used to handle UTC conversions:
6773  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
6774  */
6775 static int gmtime_emulation_type;
6776 /* number of secs to add to UTC POSIX-style time to get local time */
6777 static long int utc_offset_secs;
6778
6779 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
6780  * in vmsish.h.  #undef them here so we can call the CRTL routines
6781  * directly.
6782  */
6783 #undef gmtime
6784 #undef localtime
6785 #undef time
6786
6787
6788 /*
6789  * DEC C previous to 6.0 corrupts the behavior of the /prefix
6790  * qualifier with the extern prefix pragma.  This provisional
6791  * hack circumvents this prefix pragma problem in previous
6792  * precompilers.
6793  */
6794 #if defined(__VMS_VER) && __VMS_VER >= 70000000
6795 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
6796 #    pragma __extern_prefix save
6797 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
6798 #    define gmtime decc$__utctz_gmtime
6799 #    define localtime decc$__utctz_localtime
6800 #    define time decc$__utc_time
6801 #    pragma __extern_prefix restore
6802
6803      struct tm *gmtime(), *localtime();
6804
6805 #  endif
6806 #endif
6807
6808
6809 static time_t toutc_dst(time_t loc) {
6810   struct tm *rsltmp;
6811
6812   if ((rsltmp = localtime(&loc)) == NULL) return -1;
6813   loc -= utc_offset_secs;
6814   if (rsltmp->tm_isdst) loc -= 3600;
6815   return loc;
6816 }
6817 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6818        ((gmtime_emulation_type || my_time(NULL)), \
6819        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6820        ((secs) - utc_offset_secs))))
6821
6822 static time_t toloc_dst(time_t utc) {
6823   struct tm *rsltmp;
6824
6825   utc += utc_offset_secs;
6826   if ((rsltmp = localtime(&utc)) == NULL) return -1;
6827   if (rsltmp->tm_isdst) utc += 3600;
6828   return utc;
6829 }
6830 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6831        ((gmtime_emulation_type || my_time(NULL)), \
6832        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6833        ((secs) + utc_offset_secs))))
6834
6835 #ifndef RTL_USES_UTC
6836 /*
6837
6838     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
6839         DST starts on 1st sun of april      at 02:00  std time
6840             ends on last sun of october     at 02:00  dst time
6841     see the UCX management command reference, SET CONFIG TIMEZONE
6842     for formatting info.
6843
6844     No, it's not as general as it should be, but then again, NOTHING
6845     will handle UK times in a sensible way.
6846 */
6847
6848
6849 /*
6850     parse the DST start/end info:
6851     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6852 */
6853
6854 static char *
6855 tz_parse_startend(char *s, struct tm *w, int *past)
6856 {
6857     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6858     int ly, dozjd, d, m, n, hour, min, sec, j, k;
6859     time_t g;
6860
6861     if (!s)    return 0;
6862     if (!w) return 0;
6863     if (!past) return 0;
6864
6865     ly = 0;
6866     if (w->tm_year % 4        == 0) ly = 1;
6867     if (w->tm_year % 100      == 0) ly = 0;
6868     if (w->tm_year+1900 % 400 == 0) ly = 1;
6869     if (ly) dinm[1]++;
6870
6871     dozjd = isdigit(*s);
6872     if (*s == 'J' || *s == 'j' || dozjd) {
6873         if (!dozjd && !isdigit(*++s)) return 0;
6874         d = *s++ - '0';
6875         if (isdigit(*s)) {
6876             d = d*10 + *s++ - '0';
6877             if (isdigit(*s)) {
6878                 d = d*10 + *s++ - '0';
6879             }
6880         }
6881         if (d == 0) return 0;
6882         if (d > 366) return 0;
6883         d--;
6884         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
6885         g = d * 86400;
6886         dozjd = 1;
6887     } else if (*s == 'M' || *s == 'm') {
6888         if (!isdigit(*++s)) return 0;
6889         m = *s++ - '0';
6890         if (isdigit(*s)) m = 10*m + *s++ - '0';
6891         if (*s != '.') return 0;
6892         if (!isdigit(*++s)) return 0;
6893         n = *s++ - '0';
6894         if (n < 1 || n > 5) return 0;
6895         if (*s != '.') return 0;
6896         if (!isdigit(*++s)) return 0;
6897         d = *s++ - '0';
6898         if (d > 6) return 0;
6899     }
6900
6901     if (*s == '/') {
6902         if (!isdigit(*++s)) return 0;
6903         hour = *s++ - '0';
6904         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6905         if (*s == ':') {
6906             if (!isdigit(*++s)) return 0;
6907             min = *s++ - '0';
6908             if (isdigit(*s)) min = 10*min + *s++ - '0';
6909             if (*s == ':') {
6910                 if (!isdigit(*++s)) return 0;
6911                 sec = *s++ - '0';
6912                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6913             }
6914         }
6915     } else {
6916         hour = 2;
6917         min = 0;
6918         sec = 0;
6919     }
6920
6921     if (dozjd) {
6922         if (w->tm_yday < d) goto before;
6923         if (w->tm_yday > d) goto after;
6924     } else {
6925         if (w->tm_mon+1 < m) goto before;
6926         if (w->tm_mon+1 > m) goto after;
6927
6928         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
6929         k = d - j; /* mday of first d */
6930         if (k <= 0) k += 7;
6931         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
6932         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6933         if (w->tm_mday < k) goto before;
6934         if (w->tm_mday > k) goto after;
6935     }
6936
6937     if (w->tm_hour < hour) goto before;
6938     if (w->tm_hour > hour) goto after;
6939     if (w->tm_min  < min)  goto before;
6940     if (w->tm_min  > min)  goto after;
6941     if (w->tm_sec  < sec)  goto before;
6942     goto after;
6943
6944 before:
6945     *past = 0;
6946     return s;
6947 after:
6948     *past = 1;
6949     return s;
6950 }
6951
6952
6953
6954
6955 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
6956
6957 static char *
6958 tz_parse_offset(char *s, int *offset)
6959 {
6960     int hour = 0, min = 0, sec = 0;
6961     int neg = 0;
6962     if (!s) return 0;
6963     if (!offset) return 0;
6964
6965     if (*s == '-') {neg++; s++;}
6966     if (*s == '+') s++;
6967     if (!isdigit(*s)) return 0;
6968     hour = *s++ - '0';
6969     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6970     if (hour > 24) return 0;
6971     if (*s == ':') {
6972         if (!isdigit(*++s)) return 0;
6973         min = *s++ - '0';
6974         if (isdigit(*s)) min = min*10 + (*s++ - '0');
6975         if (min > 59) return 0;
6976         if (*s == ':') {
6977             if (!isdigit(*++s)) return 0;
6978             sec = *s++ - '0';
6979             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6980             if (sec > 59) return 0;
6981         }
6982     }
6983
6984     *offset = (hour*60+min)*60 + sec;
6985     if (neg) *offset = -*offset;
6986     return s;
6987 }
6988
6989 /*
6990     input time is w, whatever type of time the CRTL localtime() uses.
6991     sets dst, the zone, and the gmtoff (seconds)
6992
6993     caches the value of TZ and UCX$TZ env variables; note that
6994     my_setenv looks for these and sets a flag if they're changed
6995     for efficiency.
6996
6997     We have to watch out for the "australian" case (dst starts in
6998     october, ends in april)...flagged by "reverse" and checked by
6999     scanning through the months of the previous year.
7000
7001 */
7002
7003 static int
7004 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
7005 {
7006     time_t when;
7007     struct tm *w2;
7008     char *s,*s2;
7009     char *dstzone, *tz, *s_start, *s_end;
7010     int std_off, dst_off, isdst;
7011     int y, dststart, dstend;
7012     static char envtz[1025];  /* longer than any logical, symbol, ... */
7013     static char ucxtz[1025];
7014     static char reversed = 0;
7015
7016     if (!w) return 0;
7017
7018     if (tz_updated) {
7019         tz_updated = 0;
7020         reversed = -1;  /* flag need to check  */
7021         envtz[0] = ucxtz[0] = '\0';
7022         tz = my_getenv("TZ",0);
7023         if (tz) strcpy(envtz, tz);
7024         tz = my_getenv("UCX$TZ",0);
7025         if (tz) strcpy(ucxtz, tz);
7026         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
7027     }
7028     tz = envtz;
7029     if (!*tz) tz = ucxtz;
7030
7031     s = tz;
7032     while (isalpha(*s)) s++;
7033     s = tz_parse_offset(s, &std_off);
7034     if (!s) return 0;
7035     if (!*s) {                  /* no DST, hurray we're done! */
7036         isdst = 0;
7037         goto done;
7038     }
7039
7040     dstzone = s;
7041     while (isalpha(*s)) s++;
7042     s2 = tz_parse_offset(s, &dst_off);
7043     if (s2) {
7044         s = s2;
7045     } else {
7046         dst_off = std_off - 3600;
7047     }
7048
7049     if (!*s) {      /* default dst start/end?? */
7050         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
7051             s = strchr(ucxtz,',');
7052         }
7053         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
7054     }
7055     if (*s != ',') return 0;
7056
7057     when = *w;
7058     when = _toutc(when);      /* convert to utc */
7059     when = when - std_off;    /* convert to pseudolocal time*/
7060
7061     w2 = localtime(&when);
7062     y = w2->tm_year;
7063     s_start = s+1;
7064     s = tz_parse_startend(s_start,w2,&dststart);
7065     if (!s) return 0;
7066     if (*s != ',') return 0;
7067
7068     when = *w;
7069     when = _toutc(when);      /* convert to utc */
7070     when = when - dst_off;    /* convert to pseudolocal time*/
7071     w2 = localtime(&when);
7072     if (w2->tm_year != y) {   /* spans a year, just check one time */
7073         when += dst_off - std_off;
7074         w2 = localtime(&when);
7075     }
7076     s_end = s+1;
7077     s = tz_parse_startend(s_end,w2,&dstend);
7078     if (!s) return 0;
7079
7080     if (reversed == -1) {  /* need to check if start later than end */
7081         int j, ds, de;
7082
7083         when = *w;
7084         if (when < 2*365*86400) {
7085             when += 2*365*86400;
7086         } else {
7087             when -= 365*86400;
7088         }
7089         w2 =localtime(&when);
7090         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
7091
7092         for (j = 0; j < 12; j++) {
7093             w2 =localtime(&when);
7094             tz_parse_startend(s_start,w2,&ds);
7095             tz_parse_startend(s_end,w2,&de);
7096             if (ds != de) break;
7097             when += 30*86400;
7098         }
7099         reversed = 0;
7100         if (de && !ds) reversed = 1;
7101     }
7102
7103     isdst = dststart && !dstend;
7104     if (reversed) isdst = dststart  || !dstend;
7105
7106 done:
7107     if (dst)    *dst = isdst;
7108     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
7109     if (isdst)  tz = dstzone;
7110     if (zone) {
7111         while(isalpha(*tz))  *zone++ = *tz++;
7112         *zone = '\0';
7113     }
7114     return 1;
7115 }
7116
7117 #endif /* !RTL_USES_UTC */
7118
7119 /* my_time(), my_localtime(), my_gmtime()
7120  * By default traffic in UTC time values, using CRTL gmtime() or
7121  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
7122  * Note: We need to use these functions even when the CRTL has working
7123  * UTC support, since they also handle C<use vmsish qw(times);>
7124  *
7125  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
7126  * Modified by Charles Bailey <bailey@newman.upenn.edu>
7127  */
7128
7129 /*{{{time_t my_time(time_t *timep)*/
7130 time_t Perl_my_time(pTHX_ time_t *timep)
7131 {
7132   time_t when;
7133   struct tm *tm_p;
7134
7135   if (gmtime_emulation_type == 0) {
7136     int dstnow;
7137     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
7138                               /* results of calls to gmtime() and localtime() */
7139                               /* for same &base */
7140
7141     gmtime_emulation_type++;
7142     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
7143       char off[LNM$C_NAMLENGTH+1];;
7144
7145       gmtime_emulation_type++;
7146       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
7147         gmtime_emulation_type++;
7148         utc_offset_secs = 0;
7149         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
7150       }
7151       else { utc_offset_secs = atol(off); }
7152     }
7153     else { /* We've got a working gmtime() */
7154       struct tm gmt, local;
7155
7156       gmt = *tm_p;
7157       tm_p = localtime(&base);
7158       local = *tm_p;
7159       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
7160       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
7161       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
7162       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
7163     }
7164   }
7165
7166   when = time(NULL);
7167 # ifdef VMSISH_TIME
7168 # ifdef RTL_USES_UTC
7169   if (VMSISH_TIME) when = _toloc(when);
7170 # else
7171   if (!VMSISH_TIME) when = _toutc(when);
7172 # endif
7173 # endif
7174   if (timep != NULL) *timep = when;
7175   return when;
7176
7177 }  /* end of my_time() */
7178 /*}}}*/
7179
7180
7181 /*{{{struct tm *my_gmtime(const time_t *timep)*/
7182 struct tm *
7183 Perl_my_gmtime(pTHX_ const time_t *timep)
7184 {
7185   char *p;
7186   time_t when;
7187   struct tm *rsltmp;
7188
7189   if (timep == NULL) {
7190     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7191     return NULL;
7192   }
7193   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
7194
7195   when = *timep;
7196 # ifdef VMSISH_TIME
7197   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
7198 #  endif
7199 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
7200   return gmtime(&when);
7201 # else
7202   /* CRTL localtime() wants local time as input, so does no tz correction */
7203   rsltmp = localtime(&when);
7204   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
7205   return rsltmp;
7206 #endif
7207 }  /* end of my_gmtime() */
7208 /*}}}*/
7209
7210
7211 /*{{{struct tm *my_localtime(const time_t *timep)*/
7212 struct tm *
7213 Perl_my_localtime(pTHX_ const time_t *timep)
7214 {
7215   time_t when, whenutc;
7216   struct tm *rsltmp;
7217   int dst, offset;
7218
7219   if (timep == NULL) {
7220     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7221     return NULL;
7222   }
7223   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
7224   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
7225
7226   when = *timep;
7227 # ifdef RTL_USES_UTC
7228 # ifdef VMSISH_TIME
7229   if (VMSISH_TIME) when = _toutc(when);
7230 # endif
7231   /* CRTL localtime() wants UTC as input, does tz correction itself */
7232   return localtime(&when);
7233
7234 # else /* !RTL_USES_UTC */
7235   whenutc = when;
7236 # ifdef VMSISH_TIME
7237   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
7238   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
7239 # endif
7240   dst = -1;
7241 #ifndef RTL_USES_UTC
7242   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
7243       when = whenutc - offset;                   /* pseudolocal time*/
7244   }
7245 # endif
7246   /* CRTL localtime() wants local time as input, so does no tz correction */
7247   rsltmp = localtime(&when);
7248   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
7249   return rsltmp;
7250 # endif
7251
7252 } /*  end of my_localtime() */
7253 /*}}}*/
7254
7255 /* Reset definitions for later calls */
7256 #define gmtime(t)    my_gmtime(t)
7257 #define localtime(t) my_localtime(t)
7258 #define time(t)      my_time(t)
7259
7260
7261 /* my_utime - update modification time of a file
7262  * calling sequence is identical to POSIX utime(), but under
7263  * VMS only the modification time is changed; ODS-2 does not
7264  * maintain access times.  Restrictions differ from the POSIX
7265  * definition in that the time can be changed as long as the
7266  * caller has permission to execute the necessary IO$_MODIFY $QIO;
7267  * no separate checks are made to insure that the caller is the
7268  * owner of the file or has special privs enabled.
7269  * Code here is based on Joe Meadows' FILE utility.
7270  */
7271
7272 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
7273  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
7274  * in 100 ns intervals.
7275  */
7276 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
7277
7278 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
7279 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
7280 {
7281   register int i;
7282   int sts;
7283   long int bintime[2], len = 2, lowbit, unixtime,
7284            secscale = 10000000; /* seconds --> 100 ns intervals */
7285   unsigned long int chan, iosb[2], retsts;
7286   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
7287   struct FAB myfab = cc$rms_fab;
7288   struct NAM mynam = cc$rms_nam;
7289 #if defined (__DECC) && defined (__VAX)
7290   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
7291    * at least through VMS V6.1, which causes a type-conversion warning.
7292    */
7293 #  pragma message save
7294 #  pragma message disable cvtdiftypes
7295 #endif
7296   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
7297   struct fibdef myfib;
7298 #if defined (__DECC) && defined (__VAX)
7299   /* This should be right after the declaration of myatr, but due
7300    * to a bug in VAX DEC C, this takes effect a statement early.
7301    */
7302 #  pragma message restore
7303 #endif
7304   /* cast ok for read only parameter */
7305   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
7306                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
7307                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
7308
7309   if (file == NULL || *file == '\0') {
7310     set_errno(ENOENT);
7311     set_vaxc_errno(LIB$_INVARG);
7312     return -1;
7313   }
7314   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
7315
7316   if (utimes != NULL) {
7317     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
7318      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
7319      * Since time_t is unsigned long int, and lib$emul takes a signed long int
7320      * as input, we force the sign bit to be clear by shifting unixtime right
7321      * one bit, then multiplying by an extra factor of 2 in lib$emul().
7322      */
7323     lowbit = (utimes->modtime & 1) ? secscale : 0;
7324     unixtime = (long int) utimes->modtime;
7325 #   ifdef VMSISH_TIME
7326     /* If input was UTC; convert to local for sys svc */
7327     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
7328 #   endif
7329     unixtime >>= 1;  secscale <<= 1;
7330     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
7331     if (!(retsts & 1)) {
7332       set_errno(EVMSERR);
7333       set_vaxc_errno(retsts);
7334       return -1;
7335     }
7336     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
7337     if (!(retsts & 1)) {
7338       set_errno(EVMSERR);
7339       set_vaxc_errno(retsts);
7340       return -1;
7341     }
7342   }
7343   else {
7344     /* Just get the current time in VMS format directly */
7345     retsts = sys$gettim(bintime);
7346     if (!(retsts & 1)) {
7347       set_errno(EVMSERR);
7348       set_vaxc_errno(retsts);
7349       return -1;
7350     }
7351   }
7352
7353   myfab.fab$l_fna = vmsspec;
7354   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
7355   myfab.fab$l_nam = &mynam;
7356   mynam.nam$l_esa = esa;
7357   mynam.nam$b_ess = (unsigned char) sizeof esa;
7358   mynam.nam$l_rsa = rsa;
7359   mynam.nam$b_rss = (unsigned char) sizeof rsa;
7360   if (decc_efs_case_preserve)
7361       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7362
7363   /* Look for the file to be affected, letting RMS parse the file
7364    * specification for us as well.  I have set errno using only
7365    * values documented in the utime() man page for VMS POSIX.
7366    */
7367   retsts = sys$parse(&myfab,0,0);
7368   if (!(retsts & 1)) {
7369     set_vaxc_errno(retsts);
7370     if      (retsts == RMS$_PRV) set_errno(EACCES);
7371     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
7372     else                         set_errno(EVMSERR);
7373     return -1;
7374   }
7375   retsts = sys$search(&myfab,0,0);
7376   if (!(retsts & 1)) {
7377     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7378     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7379     set_vaxc_errno(retsts);
7380     if      (retsts == RMS$_PRV) set_errno(EACCES);
7381     else if (retsts == RMS$_FNF) set_errno(ENOENT);
7382     else                         set_errno(EVMSERR);
7383     return -1;
7384   }
7385
7386   devdsc.dsc$w_length = mynam.nam$b_dev;
7387   /* cast ok for read only parameter */
7388   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
7389
7390   retsts = sys$assign(&devdsc,&chan,0,0);
7391   if (!(retsts & 1)) {
7392     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7393     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7394     set_vaxc_errno(retsts);
7395     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
7396     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
7397     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
7398     else                               set_errno(EVMSERR);
7399     return -1;
7400   }
7401
7402   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
7403   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
7404
7405   memset((void *) &myfib, 0, sizeof myfib);
7406 #if defined(__DECC) || defined(__DECCXX)
7407   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
7408   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
7409   /* This prevents the revision time of the file being reset to the current
7410    * time as a result of our IO$_MODIFY $QIO. */
7411   myfib.fib$l_acctl = FIB$M_NORECORD;
7412 #else
7413   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
7414   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
7415   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
7416 #endif
7417   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
7418   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
7419   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
7420   _ckvmssts(sys$dassgn(chan));
7421   if (retsts & 1) retsts = iosb[0];
7422   if (!(retsts & 1)) {
7423     set_vaxc_errno(retsts);
7424     if (retsts == SS$_NOPRIV) set_errno(EACCES);
7425     else                      set_errno(EVMSERR);
7426     return -1;
7427   }
7428
7429   return 0;
7430 }  /* end of my_utime() */
7431 /*}}}*/
7432
7433 /*
7434  * flex_stat, flex_fstat
7435  * basic stat, but gets it right when asked to stat
7436  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
7437  */
7438
7439 /* encode_dev packs a VMS device name string into an integer to allow
7440  * simple comparisons. This can be used, for example, to check whether two
7441  * files are located on the same device, by comparing their encoded device
7442  * names. Even a string comparison would not do, because stat() reuses the
7443  * device name buffer for each call; so without encode_dev, it would be
7444  * necessary to save the buffer and use strcmp (this would mean a number of
7445  * changes to the standard Perl code, to say nothing of what a Perl script
7446  * would have to do.
7447  *
7448  * The device lock id, if it exists, should be unique (unless perhaps compared
7449  * with lock ids transferred from other nodes). We have a lock id if the disk is
7450  * mounted cluster-wide, which is when we tend to get long (host-qualified)
7451  * device names. Thus we use the lock id in preference, and only if that isn't
7452  * available, do we try to pack the device name into an integer (flagged by
7453  * the sign bit (LOCKID_MASK) being set).
7454  *
7455  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
7456  * name and its encoded form, but it seems very unlikely that we will find
7457  * two files on different disks that share the same encoded device names,
7458  * and even more remote that they will share the same file id (if the test
7459  * is to check for the same file).
7460  *
7461  * A better method might be to use sys$device_scan on the first call, and to
7462  * search for the device, returning an index into the cached array.
7463  * The number returned would be more intelligable.
7464  * This is probably not worth it, and anyway would take quite a bit longer
7465  * on the first call.
7466  */
7467 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
7468 static mydev_t encode_dev (pTHX_ const char *dev)
7469 {
7470   int i;
7471   unsigned long int f;
7472   mydev_t enc;
7473   char c;
7474   const char *q;
7475
7476   if (!dev || !dev[0]) return 0;
7477
7478 #if LOCKID_MASK
7479   {
7480     struct dsc$descriptor_s dev_desc;
7481     unsigned long int status, lockid, item = DVI$_LOCKID;
7482
7483     /* For cluster-mounted disks, the disk lock identifier is unique, so we
7484        can try that first. */
7485     dev_desc.dsc$w_length =  strlen (dev);
7486     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
7487     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
7488     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
7489     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
7490     if (lockid) return (lockid & ~LOCKID_MASK);
7491   }
7492 #endif
7493
7494   /* Otherwise we try to encode the device name */
7495   enc = 0;
7496   f = 1;
7497   i = 0;
7498   for (q = dev + strlen(dev); q--; q >= dev) {
7499     if (isdigit (*q))
7500       c= (*q) - '0';
7501     else if (isalpha (toupper (*q)))
7502       c= toupper (*q) - 'A' + (char)10;
7503     else
7504       continue; /* Skip '$'s */
7505     i++;
7506     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
7507     if (i>1) f *= 36;
7508     enc += f * (unsigned long int) c;
7509   }
7510   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
7511
7512 }  /* end of encode_dev() */
7513
7514 static char namecache[NAM$C_MAXRSS+1];
7515
7516 static int
7517 is_null_device(name)
7518     const char *name;
7519 {
7520     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
7521        The underscore prefix, controller letter, and unit number are
7522        independently optional; for our purposes, the colon punctuation
7523        is not.  The colon can be trailed by optional directory and/or
7524        filename, but two consecutive colons indicates a nodename rather
7525        than a device.  [pr]  */
7526   if (*name == '_') ++name;
7527   if (tolower(*name++) != 'n') return 0;
7528   if (tolower(*name++) != 'l') return 0;
7529   if (tolower(*name) == 'a') ++name;
7530   if (*name == '0') ++name;
7531   return (*name++ == ':') && (*name != ':');
7532 }
7533
7534 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
7535 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
7536  * subset of the applicable information.
7537  */
7538 bool
7539 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
7540 {
7541   char fname_phdev[NAM$C_MAXRSS+1];
7542   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
7543   else {
7544     char fname[NAM$C_MAXRSS+1];
7545     unsigned long int retsts;
7546     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7547                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7548
7549     /* If the struct mystat is stale, we're OOL; stat() overwrites the
7550        device name on successive calls */
7551     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
7552     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
7553     namdsc.dsc$a_pointer = fname;
7554     namdsc.dsc$w_length = sizeof fname - 1;
7555
7556     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
7557                              &namdsc,&namdsc.dsc$w_length,0,0);
7558     if (retsts & 1) {
7559       fname[namdsc.dsc$w_length] = '\0';
7560 /*
7561  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
7562  * but if someone has redefined that logical, Perl gets very lost.  Since
7563  * we have the physical device name from the stat buffer, just paste it on.
7564  */
7565       strcpy( fname_phdev, statbufp->st_devnam );
7566       strcat( fname_phdev, strrchr(fname, ':') );
7567
7568       return cando_by_name(bit,effective,fname_phdev);
7569     }
7570     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
7571       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
7572       return FALSE;
7573     }
7574     _ckvmssts(retsts);
7575     return FALSE;  /* Should never get to here */
7576   }
7577 }  /* end of cando() */
7578 /*}}}*/
7579
7580
7581 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
7582 I32
7583 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
7584 {
7585   static char usrname[L_cuserid];
7586   static struct dsc$descriptor_s usrdsc =
7587          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
7588   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
7589   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
7590   unsigned short int retlen, trnlnm_iter_count;
7591   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7592   union prvdef curprv;
7593   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
7594          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
7595   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
7596          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
7597          {0,0,0,0}};
7598   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
7599          {0,0,0,0}};
7600   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7601
7602   if (!fname || !*fname) return FALSE;
7603   /* Make sure we expand logical names, since sys$check_access doesn't */
7604   if (!strpbrk(fname,"/]>:")) {
7605     strcpy(fileified,fname);
7606     trnlnm_iter_count = 0;
7607     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
7608         trnlnm_iter_count++;
7609         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
7610     }
7611     fname = fileified;
7612   }
7613   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
7614   retlen = namdsc.dsc$w_length = strlen(vmsname);
7615   namdsc.dsc$a_pointer = vmsname;
7616   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
7617       vmsname[retlen-1] == ':') {
7618     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
7619     namdsc.dsc$w_length = strlen(fileified);
7620     namdsc.dsc$a_pointer = fileified;
7621   }
7622
7623   switch (bit) {
7624     case S_IXUSR: case S_IXGRP: case S_IXOTH:
7625       access = ARM$M_EXECUTE; break;
7626     case S_IRUSR: case S_IRGRP: case S_IROTH:
7627       access = ARM$M_READ; break;
7628     case S_IWUSR: case S_IWGRP: case S_IWOTH:
7629       access = ARM$M_WRITE; break;
7630     case S_IDUSR: case S_IDGRP: case S_IDOTH:
7631       access = ARM$M_DELETE; break;
7632     default:
7633       return FALSE;
7634   }
7635
7636   /* Before we call $check_access, create a user profile with the current
7637    * process privs since otherwise it just uses the default privs from the
7638    * UAF and might give false positives or negatives.  This only works on
7639    * VMS versions v6.0 and later since that's when sys$create_user_profile
7640    * became available.
7641    */
7642
7643   /* get current process privs and username */
7644   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
7645   _ckvmssts(iosb[0]);
7646
7647 #if defined(__VMS_VER) && __VMS_VER >= 60000000
7648
7649   /* find out the space required for the profile */
7650   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
7651                                     &usrprodsc.dsc$w_length,0));
7652
7653   /* allocate space for the profile and get it filled in */
7654   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
7655   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
7656                                     &usrprodsc.dsc$w_length,0));
7657
7658   /* use the profile to check access to the file; free profile & analyze results */
7659   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
7660   Safefree(usrprodsc.dsc$a_pointer);
7661   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
7662
7663 #else
7664
7665   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
7666
7667 #endif
7668
7669   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
7670       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
7671       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
7672     set_vaxc_errno(retsts);
7673     if (retsts == SS$_NOPRIV) set_errno(EACCES);
7674     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
7675     else set_errno(ENOENT);
7676     return FALSE;
7677   }
7678   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
7679     return TRUE;
7680   }
7681   _ckvmssts(retsts);
7682
7683   return FALSE;  /* Should never get here */
7684
7685 }  /* end of cando_by_name() */
7686 /*}}}*/
7687
7688
7689 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
7690 int
7691 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
7692 {
7693   if (!fstat(fd,(stat_t *) statbufp)) {
7694     if (statbufp == (Stat_t *) &PL_statcache) {
7695     char *cptr;
7696
7697         /* Save name for cando by name in VMS format */
7698         cptr = getname(fd, namecache, 1);
7699
7700         /* This should not happen, but just in case */
7701         if (cptr == NULL)
7702            namecache[0] = '\0';
7703     }
7704     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7705 #   ifdef RTL_USES_UTC
7706 #   ifdef VMSISH_TIME
7707     if (VMSISH_TIME) {
7708       statbufp->st_mtime = _toloc(statbufp->st_mtime);
7709       statbufp->st_atime = _toloc(statbufp->st_atime);
7710       statbufp->st_ctime = _toloc(statbufp->st_ctime);
7711     }
7712 #   endif
7713 #   else
7714 #   ifdef VMSISH_TIME
7715     if (!VMSISH_TIME) { /* Return UTC instead of local time */
7716 #   else
7717     if (1) {
7718 #   endif
7719       statbufp->st_mtime = _toutc(statbufp->st_mtime);
7720       statbufp->st_atime = _toutc(statbufp->st_atime);
7721       statbufp->st_ctime = _toutc(statbufp->st_ctime);
7722     }
7723 #endif
7724     return 0;
7725   }
7726   return -1;
7727
7728 }  /* end of flex_fstat() */
7729 /*}}}*/
7730
7731 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
7732 int
7733 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
7734 {
7735     char fileified[NAM$C_MAXRSS+1];
7736     char temp_fspec[NAM$C_MAXRSS+300];
7737     int retval = -1;
7738     int saved_errno, saved_vaxc_errno;
7739
7740     if (!fspec) return retval;
7741     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
7742     strcpy(temp_fspec, fspec);
7743     if (statbufp == (Stat_t *) &PL_statcache)
7744       do_tovmsspec(temp_fspec,namecache,0);
7745     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
7746       memset(statbufp,0,sizeof *statbufp);
7747       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
7748       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
7749       statbufp->st_uid = 0x00010001;
7750       statbufp->st_gid = 0x0001;
7751       time((time_t *)&statbufp->st_mtime);
7752       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
7753       return 0;
7754     }
7755
7756     /* Try for a directory name first.  If fspec contains a filename without
7757      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
7758      * and sea:[wine.dark]water. exist, we prefer the directory here.
7759      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
7760      * not sea:[wine.dark]., if the latter exists.  If the intended target is
7761      * the file with null type, specify this by calling flex_stat() with
7762      * a '.' at the end of fspec.
7763      */
7764     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
7765       retval = stat(fileified,(stat_t *) statbufp);
7766       if (!retval && statbufp == (Stat_t *) &PL_statcache)
7767         strcpy(namecache,fileified);
7768     }
7769     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
7770     if (!retval) {
7771       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7772 #     ifdef RTL_USES_UTC
7773 #     ifdef VMSISH_TIME
7774       if (VMSISH_TIME) {
7775         statbufp->st_mtime = _toloc(statbufp->st_mtime);
7776         statbufp->st_atime = _toloc(statbufp->st_atime);
7777         statbufp->st_ctime = _toloc(statbufp->st_ctime);
7778       }
7779 #     endif
7780 #     else
7781 #     ifdef VMSISH_TIME
7782       if (!VMSISH_TIME) { /* Return UTC instead of local time */
7783 #     else
7784       if (1) {
7785 #     endif
7786         statbufp->st_mtime = _toutc(statbufp->st_mtime);
7787         statbufp->st_atime = _toutc(statbufp->st_atime);
7788         statbufp->st_ctime = _toutc(statbufp->st_ctime);
7789       }
7790 #     endif
7791     }
7792     /* If we were successful, leave errno where we found it */
7793     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
7794     return retval;
7795
7796 }  /* end of flex_stat() */
7797 /*}}}*/
7798
7799
7800 /*{{{char *my_getlogin()*/
7801 /* VMS cuserid == Unix getlogin, except calling sequence */
7802 char *
7803 my_getlogin(void)
7804 {
7805     static char user[L_cuserid];
7806     return cuserid(user);
7807 }
7808 /*}}}*/
7809
7810
7811 /*  rmscopy - copy a file using VMS RMS routines
7812  *
7813  *  Copies contents and attributes of spec_in to spec_out, except owner
7814  *  and protection information.  Name and type of spec_in are used as
7815  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
7816  *  should try to propagate timestamps from the input file to the output file.
7817  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
7818  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
7819  *  propagated to the output file at creation iff the output file specification
7820  *  did not contain an explicit name or type, and the revision date is always
7821  *  updated at the end of the copy operation.  If it is greater than 0, then
7822  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
7823  *  other than the revision date should be propagated, and bit 1 indicates
7824  *  that the revision date should be propagated.
7825  *
7826  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7827  *
7828  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7829  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
7830  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
7831  * as part of the Perl standard distribution under the terms of the
7832  * GNU General Public License or the Perl Artistic License.  Copies
7833  * of each may be found in the Perl standard distribution.
7834  */
7835 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7836 int
7837 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
7838 {
7839     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7840          rsa[NAM$C_MAXRSS], ubf[32256];
7841     unsigned long int i, sts, sts2;
7842     struct FAB fab_in, fab_out;
7843     struct RAB rab_in, rab_out;
7844     struct NAM nam;
7845     struct XABDAT xabdat;
7846     struct XABFHC xabfhc;
7847     struct XABRDT xabrdt;
7848     struct XABSUM xabsum;
7849
7850     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
7851         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7852       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7853       return 0;
7854     }
7855
7856     fab_in = cc$rms_fab;
7857     fab_in.fab$l_fna = vmsin;
7858     fab_in.fab$b_fns = strlen(vmsin);
7859     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7860     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7861     fab_in.fab$l_fop = FAB$M_SQO;
7862     fab_in.fab$l_nam =  &nam;
7863     fab_in.fab$l_xab = (void *) &xabdat;
7864
7865     nam = cc$rms_nam;
7866     nam.nam$l_rsa = rsa;
7867     nam.nam$b_rss = sizeof(rsa);
7868     nam.nam$l_esa = esa;
7869     nam.nam$b_ess = sizeof (esa);
7870     nam.nam$b_esl = nam.nam$b_rsl = 0;
7871 #ifdef NAM$M_NO_SHORT_UPCASE
7872     if (decc_efs_case_preserve)
7873         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7874 #endif
7875
7876     xabdat = cc$rms_xabdat;        /* To get creation date */
7877     xabdat.xab$l_nxt = (void *) &xabfhc;
7878
7879     xabfhc = cc$rms_xabfhc;        /* To get record length */
7880     xabfhc.xab$l_nxt = (void *) &xabsum;
7881
7882     xabsum = cc$rms_xabsum;        /* To get key and area information */
7883
7884     if (!((sts = sys$open(&fab_in)) & 1)) {
7885       set_vaxc_errno(sts);
7886       switch (sts) {
7887         case RMS$_FNF: case RMS$_DNF:
7888           set_errno(ENOENT); break;
7889         case RMS$_DIR:
7890           set_errno(ENOTDIR); break;
7891         case RMS$_DEV:
7892           set_errno(ENODEV); break;
7893         case RMS$_SYN:
7894           set_errno(EINVAL); break;
7895         case RMS$_PRV:
7896           set_errno(EACCES); break;
7897         default:
7898           set_errno(EVMSERR);
7899       }
7900       return 0;
7901     }
7902
7903     fab_out = fab_in;
7904     fab_out.fab$w_ifi = 0;
7905     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7906     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7907     fab_out.fab$l_fop = FAB$M_SQO;
7908     fab_out.fab$l_fna = vmsout;
7909     fab_out.fab$b_fns = strlen(vmsout);
7910     fab_out.fab$l_dna = nam.nam$l_name;
7911     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7912
7913     if (preserve_dates == 0) {  /* Act like DCL COPY */
7914       nam.nam$b_nop |= NAM$M_SYNCHK;
7915       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
7916       if (!((sts = sys$parse(&fab_out)) & 1)) {
7917         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7918         set_vaxc_errno(sts);
7919         return 0;
7920       }
7921       fab_out.fab$l_xab = (void *) &xabdat;
7922       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7923     }
7924     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
7925     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
7926       preserve_dates =0;      /* bitmask from this point forward   */
7927
7928     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7929     if (!((sts = sys$create(&fab_out)) & 1)) {
7930       set_vaxc_errno(sts);
7931       switch (sts) {
7932         case RMS$_DNF:
7933           set_errno(ENOENT); break;
7934         case RMS$_DIR:
7935           set_errno(ENOTDIR); break;
7936         case RMS$_DEV:
7937           set_errno(ENODEV); break;
7938         case RMS$_SYN:
7939           set_errno(EINVAL); break;
7940         case RMS$_PRV:
7941           set_errno(EACCES); break;
7942         default:
7943           set_errno(EVMSERR);
7944       }
7945       return 0;
7946     }
7947     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
7948     if (preserve_dates & 2) {
7949       /* sys$close() will process xabrdt, not xabdat */
7950       xabrdt = cc$rms_xabrdt;
7951 #ifndef __GNUC__
7952       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7953 #else
7954       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7955        * is unsigned long[2], while DECC & VAXC use a struct */
7956       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7957 #endif
7958       fab_out.fab$l_xab = (void *) &xabrdt;
7959     }
7960
7961     rab_in = cc$rms_rab;
7962     rab_in.rab$l_fab = &fab_in;
7963     rab_in.rab$l_rop = RAB$M_BIO;
7964     rab_in.rab$l_ubf = ubf;
7965     rab_in.rab$w_usz = sizeof ubf;
7966     if (!((sts = sys$connect(&rab_in)) & 1)) {
7967       sys$close(&fab_in); sys$close(&fab_out);
7968       set_errno(EVMSERR); set_vaxc_errno(sts);
7969       return 0;
7970     }
7971
7972     rab_out = cc$rms_rab;
7973     rab_out.rab$l_fab = &fab_out;
7974     rab_out.rab$l_rbf = ubf;
7975     if (!((sts = sys$connect(&rab_out)) & 1)) {
7976       sys$close(&fab_in); sys$close(&fab_out);
7977       set_errno(EVMSERR); set_vaxc_errno(sts);
7978       return 0;
7979     }
7980
7981     while ((sts = sys$read(&rab_in))) {  /* always true  */
7982       if (sts == RMS$_EOF) break;
7983       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7984       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7985         sys$close(&fab_in); sys$close(&fab_out);
7986         set_errno(EVMSERR); set_vaxc_errno(sts);
7987         return 0;
7988       }
7989     }
7990
7991     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
7992     sys$close(&fab_in);  sys$close(&fab_out);
7993     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7994     if (!(sts & 1)) {
7995       set_errno(EVMSERR); set_vaxc_errno(sts);
7996       return 0;
7997     }
7998
7999     return 1;
8000
8001 }  /* end of rmscopy() */
8002 /*}}}*/
8003
8004
8005 /***  The following glue provides 'hooks' to make some of the routines
8006  * from this file available from Perl.  These routines are sufficiently
8007  * basic, and are required sufficiently early in the build process,
8008  * that's it's nice to have them available to miniperl as well as the
8009  * full Perl, so they're set up here instead of in an extension.  The
8010  * Perl code which handles importation of these names into a given
8011  * package lives in [.VMS]Filespec.pm in @INC.
8012  */
8013
8014 void
8015 rmsexpand_fromperl(pTHX_ CV *cv)
8016 {
8017   dXSARGS;
8018   char *fspec, *defspec = NULL, *rslt;
8019   STRLEN n_a;
8020
8021   if (!items || items > 2)
8022     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
8023   fspec = SvPV(ST(0),n_a);
8024   if (!fspec || !*fspec) XSRETURN_UNDEF;
8025   if (items == 2) defspec = SvPV(ST(1),n_a);
8026
8027   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
8028   ST(0) = sv_newmortal();
8029   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
8030   XSRETURN(1);
8031 }
8032
8033 void
8034 vmsify_fromperl(pTHX_ CV *cv)
8035 {
8036   dXSARGS;
8037   char *vmsified;
8038   STRLEN n_a;
8039
8040   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
8041   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
8042   ST(0) = sv_newmortal();
8043   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
8044   XSRETURN(1);
8045 }
8046
8047 void
8048 unixify_fromperl(pTHX_ CV *cv)
8049 {
8050   dXSARGS;
8051   char *unixified;
8052   STRLEN n_a;
8053
8054   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
8055   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
8056   ST(0) = sv_newmortal();
8057   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
8058   XSRETURN(1);
8059 }
8060
8061 void
8062 fileify_fromperl(pTHX_ CV *cv)
8063 {
8064   dXSARGS;
8065   char *fileified;
8066   STRLEN n_a;
8067
8068   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
8069   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
8070   ST(0) = sv_newmortal();
8071   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
8072   XSRETURN(1);
8073 }
8074
8075 void
8076 pathify_fromperl(pTHX_ CV *cv)
8077 {
8078   dXSARGS;
8079   char *pathified;
8080   STRLEN n_a;
8081
8082   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
8083   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
8084   ST(0) = sv_newmortal();
8085   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
8086   XSRETURN(1);
8087 }
8088
8089 void
8090 vmspath_fromperl(pTHX_ CV *cv)
8091 {
8092   dXSARGS;
8093   char *vmspath;
8094   STRLEN n_a;
8095
8096   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
8097   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
8098   ST(0) = sv_newmortal();
8099   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
8100   XSRETURN(1);
8101 }
8102
8103 void
8104 unixpath_fromperl(pTHX_ CV *cv)
8105 {
8106   dXSARGS;
8107   char *unixpath;
8108   STRLEN n_a;
8109
8110   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
8111   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
8112   ST(0) = sv_newmortal();
8113   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
8114   XSRETURN(1);
8115 }
8116
8117 void
8118 candelete_fromperl(pTHX_ CV *cv)
8119 {
8120   dXSARGS;
8121   char fspec[NAM$C_MAXRSS+1], *fsp;
8122   SV *mysv;
8123   IO *io;
8124   STRLEN n_a;
8125
8126   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
8127
8128   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8129   if (SvTYPE(mysv) == SVt_PVGV) {
8130     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
8131       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8132       ST(0) = &PL_sv_no;
8133       XSRETURN(1);
8134     }
8135     fsp = fspec;
8136   }
8137   else {
8138     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
8139       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8140       ST(0) = &PL_sv_no;
8141       XSRETURN(1);
8142     }
8143   }
8144
8145   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
8146   XSRETURN(1);
8147 }
8148
8149 void
8150 rmscopy_fromperl(pTHX_ CV *cv)
8151 {
8152   dXSARGS;
8153   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
8154   int date_flag;
8155   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
8156                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8157   unsigned long int sts;
8158   SV *mysv;
8159   IO *io;
8160   STRLEN n_a;
8161
8162   if (items < 2 || items > 3)
8163     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
8164
8165   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8166   if (SvTYPE(mysv) == SVt_PVGV) {
8167     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
8168       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8169       ST(0) = &PL_sv_no;
8170       XSRETURN(1);
8171     }
8172     inp = inspec;
8173   }
8174   else {
8175     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
8176       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8177       ST(0) = &PL_sv_no;
8178       XSRETURN(1);
8179     }
8180   }
8181   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
8182   if (SvTYPE(mysv) == SVt_PVGV) {
8183     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
8184       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8185       ST(0) = &PL_sv_no;
8186       XSRETURN(1);
8187     }
8188     outp = outspec;
8189   }
8190   else {
8191     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
8192       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8193       ST(0) = &PL_sv_no;
8194       XSRETURN(1);
8195     }
8196   }
8197   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
8198
8199   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
8200   XSRETURN(1);
8201 }
8202
8203
8204 void
8205 mod2fname(pTHX_ CV *cv)
8206 {
8207   dXSARGS;
8208   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
8209        workbuff[NAM$C_MAXRSS*1 + 1];
8210   int total_namelen = 3, counter, num_entries;
8211   /* ODS-5 ups this, but we want to be consistent, so... */
8212   int max_name_len = 39;
8213   AV *in_array = (AV *)SvRV(ST(0));
8214
8215   num_entries = av_len(in_array);
8216
8217   /* All the names start with PL_. */
8218   strcpy(ultimate_name, "PL_");
8219
8220   /* Clean up our working buffer */
8221   Zero(work_name, sizeof(work_name), char);
8222
8223   /* Run through the entries and build up a working name */
8224   for(counter = 0; counter <= num_entries; counter++) {
8225     /* If it's not the first name then tack on a __ */
8226     if (counter) {
8227       strcat(work_name, "__");
8228     }
8229     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
8230                            PL_na));
8231   }
8232
8233   /* Check to see if we actually have to bother...*/
8234   if (strlen(work_name) + 3 <= max_name_len) {
8235     strcat(ultimate_name, work_name);
8236   } else {
8237     /* It's too darned big, so we need to go strip. We use the same */
8238     /* algorithm as xsubpp does. First, strip out doubled __ */
8239     char *source, *dest, last;
8240     dest = workbuff;
8241     last = 0;
8242     for (source = work_name; *source; source++) {
8243       if (last == *source && last == '_') {
8244         continue;
8245       }
8246       *dest++ = *source;
8247       last = *source;
8248     }
8249     /* Go put it back */
8250     strcpy(work_name, workbuff);
8251     /* Is it still too big? */
8252     if (strlen(work_name) + 3 > max_name_len) {
8253       /* Strip duplicate letters */
8254       last = 0;
8255       dest = workbuff;
8256       for (source = work_name; *source; source++) {
8257         if (last == toupper(*source)) {
8258         continue;
8259         }
8260         *dest++ = *source;
8261         last = toupper(*source);
8262       }
8263       strcpy(work_name, workbuff);
8264     }
8265
8266     /* Is it *still* too big? */
8267     if (strlen(work_name) + 3 > max_name_len) {
8268       /* Too bad, we truncate */
8269       work_name[max_name_len - 2] = 0;
8270     }
8271     strcat(ultimate_name, work_name);
8272   }
8273
8274   /* Okay, return it */
8275   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
8276   XSRETURN(1);
8277 }
8278
8279 void
8280 hushexit_fromperl(pTHX_ CV *cv)
8281 {
8282     dXSARGS;
8283
8284     if (items > 0) {
8285         VMSISH_HUSHED = SvTRUE(ST(0));
8286     }
8287     ST(0) = boolSV(VMSISH_HUSHED);
8288     XSRETURN(1);
8289 }
8290
8291 void
8292 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
8293                           struct interp_intern *dst)
8294 {
8295     memcpy(dst,src,sizeof(struct interp_intern));
8296 }
8297
8298 void
8299 Perl_sys_intern_clear(pTHX)
8300 {
8301 }
8302
8303 void
8304 Perl_sys_intern_init(pTHX)
8305 {
8306     unsigned int ix = RAND_MAX;
8307     double x;
8308
8309     VMSISH_HUSHED = 0;
8310
8311     x = (float)ix;
8312     MY_INV_RAND_MAX = 1./x;
8313 }
8314
8315 void
8316 init_os_extras(void)
8317 {
8318   dTHX;
8319   char* file = __FILE__;
8320   char temp_buff[512];
8321   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
8322     no_translate_barewords = TRUE;
8323   } else {
8324     no_translate_barewords = FALSE;
8325   }
8326
8327   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
8328   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
8329   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
8330   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
8331   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
8332   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
8333   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
8334   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
8335   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
8336   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
8337   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
8338 #ifdef HAS_SYMLINK
8339   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
8340 #endif
8341 #if 0 /* future */
8342 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8343   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
8344 #endif
8345 #endif
8346
8347   store_pipelocs(aTHX);         /* will redo any earlier attempts */
8348
8349   return;
8350 }
8351
8352 #ifdef HAS_SYMLINK
8353
8354 #if __CRTL_VER == 80200000
8355 /* This missed getting in to the DECC SDK for 8.2 */
8356 char *realpath(const char *file_name, char * resolved_name, ...);
8357 #endif
8358
8359 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
8360 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
8361  * The perl fallback routine to provide realpath() is not as efficient
8362  * on OpenVMS.
8363  */
8364 static char *
8365 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8366 {
8367     return realpath(filespec, outbuf);
8368 }
8369
8370 /*}}}*/
8371 /* External entry points */
8372 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8373 { return do_vms_realpath(filespec, outbuf); }
8374 #else
8375 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8376 { return NULL; }
8377 #endif
8378
8379
8380 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8381 /* case_tolerant */
8382
8383 /*{{{int do_vms_case_tolerant(void)*/
8384 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
8385  * controlled by a process setting.
8386  */
8387 int do_vms_case_tolerant(void)
8388 {
8389     return vms_process_case_tolerant;
8390 }
8391 /*}}}*/
8392 /* External entry points */
8393 int Perl_vms_case_tolerant(void)
8394 { return do_vms_case_tolerant(); }
8395 #else
8396 int Perl_vms_case_tolerant(void)
8397 { return vms_process_case_tolerant; }
8398 #endif
8399
8400
8401  /* Start of DECC RTL Feature handling */
8402
8403 static int sys_trnlnm
8404    (const char * logname,
8405     char * value,
8406     int value_len)
8407 {
8408     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
8409     const unsigned long attr = LNM$M_CASE_BLIND;
8410     struct dsc$descriptor_s name_dsc;
8411     int status;
8412     unsigned short result;
8413     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
8414                                 {0, 0, 0, 0}};
8415
8416     name_dsc.dsc$w_length = strlen(logname);
8417     name_dsc.dsc$a_pointer = (char *)logname;
8418     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8419     name_dsc.dsc$b_class = DSC$K_CLASS_S;
8420
8421     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
8422
8423     if ($VMS_STATUS_SUCCESS(status)) {
8424
8425          /* Null terminate and return the string */
8426         /*--------------------------------------*/
8427         value[result] = 0;
8428     }
8429
8430     return status;
8431 }
8432
8433 static int sys_crelnm
8434    (const char * logname,
8435     const char * value)
8436 {
8437     int ret_val;
8438     const char * proc_table = "LNM$PROCESS_TABLE";
8439     struct dsc$descriptor_s proc_table_dsc;
8440     struct dsc$descriptor_s logname_dsc;
8441     struct itmlst_3 item_list[2];
8442
8443     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
8444     proc_table_dsc.dsc$w_length = strlen(proc_table);
8445     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8446     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
8447
8448     logname_dsc.dsc$a_pointer = (char *) logname;
8449     logname_dsc.dsc$w_length = strlen(logname);
8450     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8451     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
8452
8453     item_list[0].buflen = strlen(value);
8454     item_list[0].itmcode = LNM$_STRING;
8455     item_list[0].bufadr = (char *)value;
8456     item_list[0].retlen = NULL;
8457
8458     item_list[1].buflen = 0;
8459     item_list[1].itmcode = 0;
8460
8461     ret_val = sys$crelnm
8462                        (NULL,
8463                         (const struct dsc$descriptor_s *)&proc_table_dsc,
8464                         (const struct dsc$descriptor_s *)&logname_dsc,
8465                         NULL,
8466                         (const struct item_list_3 *) item_list);
8467
8468     return ret_val;
8469 }
8470
8471
8472 /* C RTL Feature settings */
8473
8474 static int set_features
8475    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
8476     int (* cli_routine)(void),  /* Not documented */
8477     void *image_info)           /* Not documented */
8478 {
8479     int status;
8480     int s;
8481     int dflt;
8482     char* str;
8483     char val_str[10];
8484     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
8485     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
8486     unsigned long case_perm;
8487     unsigned long case_image;
8488
8489 #if __CRTL_VER >= 70300000 && !defined(__VAX)
8490     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
8491     if (s >= 0) {
8492         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
8493         if (decc_disable_to_vms_logname_translation < 0)
8494             decc_disable_to_vms_logname_translation = 0;
8495     }
8496
8497     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
8498     if (s >= 0) {
8499         decc_efs_case_preserve = decc$feature_get_value(s, 1);
8500         if (decc_efs_case_preserve < 0)
8501             decc_efs_case_preserve = 0;
8502     }
8503
8504     s = decc$feature_get_index("DECC$EFS_CHARSET");
8505     if (s >= 0) {
8506         decc_efs_charset = decc$feature_get_value(s, 1);
8507         if (decc_efs_charset < 0)
8508             decc_efs_charset = 0;
8509     }
8510
8511     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
8512     if (s >= 0) {
8513         decc_filename_unix_report = decc$feature_get_value(s, 1);
8514         if (decc_filename_unix_report > 0)
8515             decc_filename_unix_report = 1;
8516         else
8517             decc_filename_unix_report = 0;
8518     }
8519
8520     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
8521     if (s >= 0) {
8522         decc_filename_unix_only = decc$feature_get_value(s, 1);
8523         if (decc_filename_unix_only > 0) {
8524             decc_filename_unix_only = 1;
8525         }
8526         else {
8527             decc_filename_unix_only = 0;
8528         }
8529     }
8530
8531     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
8532     if (s >= 0) {
8533         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
8534         if (decc_filename_unix_no_version < 0)
8535             decc_filename_unix_no_version = 0;
8536     }
8537
8538     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
8539     if (s >= 0) {
8540         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
8541         if (decc_readdir_dropdotnotype < 0)
8542             decc_readdir_dropdotnotype = 0;
8543     }
8544
8545     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
8546     if ($VMS_STATUS_SUCCESS(status)) {
8547         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
8548         if (s >= 0) {
8549             dflt = decc$feature_get_value(s, 4);
8550             if (dflt > 0) {
8551                 decc_disable_posix_root = decc$feature_get_value(s, 1);
8552                 if (decc_disable_posix_root <= 0) {
8553                     decc$feature_set_value(s, 1, 1);
8554                     decc_disable_posix_root = 1;
8555                 }
8556             }
8557             else {
8558                 /* Traditionally Perl assumes this is off */
8559                 decc_disable_posix_root = 1;
8560                 decc$feature_set_value(s, 1, 1);
8561             }
8562         }
8563     }
8564
8565 #if __CRTL_VER >= 80200000
8566     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
8567     if (s >= 0) {
8568         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
8569         if (decc_posix_compliant_pathnames < 0)
8570             decc_posix_compliant_pathnames = 0;
8571         if (decc_posix_compliant_pathnames > 4)
8572             decc_posix_compliant_pathnames = 0;
8573     }
8574
8575 #endif
8576 #else
8577     status = sys_trnlnm
8578         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
8579     if ($VMS_STATUS_SUCCESS(status)) {
8580         val_str[0] = _toupper(val_str[0]);
8581         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8582            decc_disable_to_vms_logname_translation = 1;
8583         }
8584     }
8585
8586 #ifndef __VAX
8587     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
8588     if ($VMS_STATUS_SUCCESS(status)) {
8589         val_str[0] = _toupper(val_str[0]);
8590         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8591            decc_efs_case_preserve = 1;
8592         }
8593     }
8594 #endif
8595
8596     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
8597     if ($VMS_STATUS_SUCCESS(status)) {
8598         val_str[0] = _toupper(val_str[0]);
8599         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8600            decc_filename_unix_report = 1;
8601         }
8602     }
8603     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", 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_only = 1;
8608            decc_filename_unix_report = 1;
8609         }
8610     }
8611     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
8612     if ($VMS_STATUS_SUCCESS(status)) {
8613         val_str[0] = _toupper(val_str[0]);
8614         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8615            decc_filename_unix_no_version = 1;
8616         }
8617     }
8618     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
8619     if ($VMS_STATUS_SUCCESS(status)) {
8620         val_str[0] = _toupper(val_str[0]);
8621         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8622            decc_readdir_dropdotnotype = 1;
8623         }
8624     }
8625 #endif
8626
8627 #ifndef __VAX
8628
8629      /* Report true case tolerance */
8630     /*----------------------------*/
8631     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
8632     if (!$VMS_STATUS_SUCCESS(status))
8633         case_perm = PPROP$K_CASE_BLIND;
8634     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
8635     if (!$VMS_STATUS_SUCCESS(status))
8636         case_image = PPROP$K_CASE_BLIND;
8637     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
8638         (case_image == PPROP$K_CASE_SENSITIVE))
8639         vms_process_case_tolerant = 0;
8640
8641 #endif
8642
8643
8644     /* CRTL can be initialized past this point, but not before. */
8645 /*    DECC$CRTL_INIT(); */
8646
8647     return SS$_NORMAL;
8648 }
8649
8650 #ifdef __DECC
8651 /* DECC dependent attributes */
8652 #if __DECC_VER < 60560002
8653 #define relative
8654 #define not_executable
8655 #else
8656 #define relative ,rel
8657 #define not_executable ,noexe
8658 #endif
8659 #pragma nostandard
8660 #pragma extern_model save
8661 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
8662 #endif
8663         const __align (LONGWORD) int spare[8] = {0};
8664 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
8665 /*                        NOWRT, LONG */
8666 #ifdef __DECC
8667 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
8668         nowrt,noshr relative not_executable
8669 #endif
8670 const long vms_cc_features = (const long)set_features;
8671
8672 /*
8673 ** Force a reference to LIB$INITIALIZE to ensure it
8674 ** exists in the image.
8675 */
8676 int lib$initialize(void);
8677 #ifdef __DECC
8678 #pragma extern_model strict_refdef
8679 #endif
8680     int lib_init_ref = (int) lib$initialize;
8681
8682 #ifdef __DECC
8683 #pragma extern_model restore
8684 #pragma standard
8685 #endif
8686
8687 /*  End of vms.c */