vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  *
   5  * Last revised: 20-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
   6  * Version: 5.5.60
   7  */
   8
   9 #include <acedef.h>
  10 #include <acldef.h>
  11 #include <armdef.h>
  12 #include <atrdef.h>
  13 #include <chpdef.h>
  14 #include <clidef.h>
  15 #include <climsgdef.h>
  16 #include <descrip.h>
  17 #include <dvidef.h>
  18 #include <fibdef.h>
  19 #include <float.h>
  20 #include <fscndef.h>
  21 #include <iodef.h>
  22 #include <jpidef.h>
  23 #include <kgbdef.h>
  24 #include <libclidef.h>
  25 #include <libdef.h>
  26 #include <lib$routines.h>
  27 #include <lnmdef.h>
  28 #include <prvdef.h>
  29 #include <psldef.h>
  30 #include <rms.h>
  31 #include <shrdef.h>
  32 #include <ssdef.h>
  33 #include <starlet.h>
  34 #include <strdef.h>
  35 #include <str$routines.h>
  36 #include <syidef.h>
  37 #include <uaidef.h>
  38 #include <uicdef.h>
  39
  40 /* Older versions of ssdef.h don't have these */
  41 #ifndef SS$_INVFILFOROP
  42 #  define SS$_INVFILFOROP 3930
  43 #endif
  44 #ifndef SS$_NOSUCHOBJECT
  45 #  define SS$_NOSUCHOBJECT 2696
  46 #endif
  47
  48 /* Don't replace system definitions of vfork, getenv, and stat,
  49  * code below needs to get to the underlying CRTL routines. */
  50 #define DONT_MASK_RTL_CALLS
  51 #include "EXTERN.h"
  52 #include "perl.h"
  53 #include "XSUB.h"
  54 /* Anticipating future expansion in lexical warnings . . . */
  55 #ifndef WARN_INTERNAL
  56 #  define WARN_INTERNAL WARN_MISC
  57 #endif
  58
  59 /* gcc's header files don't #define direct access macros
  60  * corresponding to VAXC's variant structs */
  61 #ifdef __GNUC__
  62 #  define uic$v_format uic$r_uic_form.uic$v_format
  63 #  define uic$v_group uic$r_uic_form.uic$v_group
  64 #  define uic$v_member uic$r_uic_form.uic$v_member
  65 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  66 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  67 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  68 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  69 #endif
  70
  71 #if defined(NEED_AN_H_ERRNO)
  72 dEXT int h_errno;
  73 #endif
  74
  75 struct itmlst_3 {
  76   unsigned short int buflen;
  77   unsigned short int itmcode;
  78   void *bufadr;
  79   unsigned short int *retlen;
  80 };
  81
  82 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
  83 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
  84 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
  85 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
  86 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
  87 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
  88 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
  89 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
  90 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
  91
  92 static char *__mystrtolower(char *str)
  93 {
  94   if (str) for (; *str; ++str) *str= tolower(*str);
  95   return str;
  96 }
  97
  98 static struct dsc$descriptor_s fildevdsc =
  99   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 100 static struct dsc$descriptor_s crtlenvdsc =
 101   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 102 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 103 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 104 static struct dsc$descriptor_s **env_tables = defenv;
 105 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 106
 107 /* True if we shouldn't treat barewords as logicals during directory */
 108 /* munching */
 109 static int no_translate_barewords;
 110
 111 /* Temp for subprocess commands */
 112 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
 113
 114 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 115 int
 116 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
 117   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 118 {
 119     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
 120     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 121     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 122     unsigned char acmode;
 123     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 124                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 125     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 126                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 127                                  {0, 0, 0, 0}};
 128     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 129 #if defined(USE_THREADS)
 130     /* We jump through these hoops because we can be called at */
 131     /* platform-specific initialization time, which is before anything is */
 132     /* set up--we can't even do a plain dTHX since that relies on the */
 133     /* interpreter structure to be initialized */
 134     struct perl_thread *thr;
 135     if (PL_curinterp) {
 136       thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 137     } else {
 138       thr = NULL;
 139     }
 140 #endif
 141
 142     if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
 143       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 144     }
 145     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 146       *cp2 = _toupper(*cp1);
 147       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 148         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 149         return 0;
 150       }
 151     }
 152     lnmdsc.dsc$w_length = cp1 - lnm;
 153     lnmdsc.dsc$a_pointer = uplnm;
 154     uplnm[lnmdsc.dsc$w_length] = '\0';
 155     secure = flags & PERL__TRNENV_SECURE;
 156     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 157     if (!tabvec || !*tabvec) tabvec = env_tables;
 158
 159     for (curtab = 0; tabvec[curtab]; curtab++) {
 160       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 161         if (!ivenv && !secure) {
 162           char *eq, *end;
 163           int i;
 164           if (!environ) {
 165             ivenv = 1;
 166             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 167             continue;
 168           }
 169           retsts = SS$_NOLOGNAM;
 170           for (i = 0; environ[i]; i++) {
 171             if ((eq = strchr(environ[i],'=')) &&
 172                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 173               eq++;
 174               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 175               if (!eqvlen) continue;
 176               retsts = SS$_NORMAL;
 177               break;
 178             }
 179           }
 180           if (retsts != SS$_NOLOGNAM) break;
 181         }
 182       }
 183       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 184                !str$case_blind_compare(&tmpdsc,&clisym)) {
 185         if (!ivsym && !secure) {
 186           unsigned short int deflen = LNM$C_NAMLENGTH;
 187           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 188           /* dynamic dsc to accomodate possible long value */
 189           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 190           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 191           if (retsts & 1) {
 192             if (eqvlen > 1024) {
 193               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 194               eqvlen = 1024;
 195               /* Special hack--we might be called before the interpreter's */
 196               /* fully initialized, in which case either thr or PL_curcop */
 197               /* might be bogus. We have to check, since ckWARN needs them */
 198               /* both to be valid if running threaded */
 199 #if defined(USE_THREADS)
 200               if (thr && PL_curcop) {
 201 #endif
 202                 if (ckWARN(WARN_MISC)) {
 203                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 204                 }
 205 #if defined(USE_THREADS)
 206               } else {
 207                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 208               }
 209 #endif
 210
 211             }
 212             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 213           }
 214           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 215           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 216           if (retsts == LIB$_NOSUCHSYM) continue;
 217           break;
 218         }
 219       }
 220       else if (!ivlnm) {
 221         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 222         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 223         if (retsts == SS$_NOLOGNAM) continue;
 224         /* PPFs have a prefix */
 225         if (
 226 #if INTSIZE == 4
 227              *((int *)uplnm) == *((int *)"SYS$")                    &&
 228 #endif
 229              eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 230              ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 231                (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 232                (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 233                (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 234           memcpy(eqv,eqv+4,eqvlen-4);
 235           eqvlen -= 4;
 236         }
 237         break;
 238       }
 239     }
 240     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 241     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 242              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 243              retsts == SS$_NOLOGNAM) {
 244       set_errno(EINVAL);  set_vaxc_errno(retsts);
 245     }
 246     else _ckvmssts(retsts);
 247     return 0;
 248 }  /* end of vmstrnenv */
 249 /*}}}*/
 250
 251 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 252 /* Define as a function so we can access statics. */
 253 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 254 {
 255   return vmstrnenv(lnm,eqv,idx,fildev,
 256 #ifdef SECURE_INTERNAL_GETENV
 257                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 258 #else
 259                    0
 260 #endif
 261                                                                               );
 262 }
 263 /*}}}*/
 264
 265 /* my_getenv
 266  * Note: Uses Perl temp to store result so char * can be returned to
 267  * caller; this pointer will be invalidated at next Perl statement
 268  * transition.
 269  * We define this as a function rather than a macro in terms of my_getenv_len()
 270  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 271  * allocate SVs).
 272  */
 273 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 274 char *
 275 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 276 {
 277     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
 278     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
 279     unsigned long int idx = 0;
 280     int trnsuccess;
 281     SV *tmpsv;
 282
 283     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 284       /* Set up a temporary buffer for the return value; Perl will
 285        * clean it up at the next statement transition */
 286       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 287       if (!tmpsv) return NULL;
 288       eqv = SvPVX(tmpsv);
 289     }
 290     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
 291     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 292     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 293       getcwd(eqv,LNM$C_NAMLENGTH);
 294       return eqv;
 295     }
 296     else {
 297       if ((cp2 = strchr(lnm,';')) != NULL) {
 298         strcpy(uplnm,lnm);
 299         uplnm[cp2-lnm] = '\0';
 300         idx = strtoul(cp2+1,NULL,0);
 301         lnm = uplnm;
 302       }
 303       /* Impose security constraints only if tainting */
 304       if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
 305       if (vmstrnenv(lnm,eqv,idx,
 306                     sys ? fildev : NULL,
 307 #ifdef SECURE_INTERNAL_GETENV
 308                     sys ? PERL__TRNENV_SECURE : 0
 309 #else
 310                                                 0
 311 #endif
 312                                                  )) return eqv;
 313       else return Nullch;
 314     }
 315
 316 }  /* end of my_getenv() */
 317 /*}}}*/
 318
 319
 320 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 321 char *
 322 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
 323 {
 324     dTHX;
 325     char *buf, *cp1, *cp2;
 326     unsigned long idx = 0;
 327     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
 328     SV *tmpsv;
 329
 330     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 331       /* Set up a temporary buffer for the return value; Perl will
 332        * clean it up at the next statement transition */
 333       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 334       if (!tmpsv) return NULL;
 335       buf = SvPVX(tmpsv);
 336     }
 337     else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
 338     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 339     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 340       getcwd(buf,LNM$C_NAMLENGTH);
 341       *len = strlen(buf);
 342       return buf;
 343     }
 344     else {
 345       if ((cp2 = strchr(lnm,';')) != NULL) {
 346         strcpy(buf,lnm);
 347         buf[cp2-lnm] = '\0';
 348         idx = strtoul(cp2+1,NULL,0);
 349         lnm = buf;
 350       }
 351       /* Impose security constraints only if tainting */
 352       if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
 353       if ((*len = vmstrnenv(lnm,buf,idx,
 354                            sys ? fildev : NULL,
 355 #ifdef SECURE_INTERNAL_GETENV
 356                            sys ? PERL__TRNENV_SECURE : 0
 357 #else
 358                                                        0
 359 #endif
 360                                                          )))
 361           return buf;
 362       else
 363           return Nullch;
 364     }
 365
 366 }  /* end of my_getenv_len() */
 367 /*}}}*/
 368
 369 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
 370
 371 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 372
 373 /*{{{ void prime_env_iter() */
 374 void
 375 prime_env_iter(void)
 376 /* Fill the %ENV associative array with all logical names we can
 377  * find, in preparation for iterating over it.
 378  */
 379 {
 380   dTHX;
 381   static int primed = 0;
 382   HV *seenhv = NULL, *envhv;
 383   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 384   unsigned short int chan;
 385 #ifndef CLI$M_TRUSTED
 386 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 387 #endif
 388   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 389   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 390   long int i;
 391   bool have_sym = FALSE, have_lnm = FALSE;
 392   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 393   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 394   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 395   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 396   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 397 #if defined(USE_THREADS) || defined(USE_ITHREADS)
 398   static perl_mutex primenv_mutex;
 399   MUTEX_INIT(&primenv_mutex);
 400 #endif
 401
 402   if (primed || !PL_envgv) return;
 403   MUTEX_LOCK(&primenv_mutex);
 404   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 405   envhv = GvHVn(PL_envgv);
 406   /* Perform a dummy fetch as an lval to insure that the hash table is
 407    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 408   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 409
 410   for (i = 0; env_tables[i]; i++) {
 411      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 412          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 413      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 414   }
 415   if (have_sym || have_lnm) {
 416     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 417     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 418     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 419     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 420   }
 421
 422   for (i--; i >= 0; i--) {
 423     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 424       char *start;
 425       int j;
 426       for (j = 0; environ[j]; j++) {
 427         if (!(start = strchr(environ[j],'='))) {
 428           if (ckWARN(WARN_INTERNAL))
 429             Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 430         }
 431         else {
 432           start++;
 433           (void) hv_store(envhv,environ[j],start - environ[j] - 1,
 434                           newSVpv(start,0),0);
 435         }
 436       }
 437       continue;
 438     }
 439     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 440              !str$case_blind_compare(&tmpdsc,&clisym)) {
 441       strcpy(cmd,"Show Symbol/Global *");
 442       cmddsc.dsc$w_length = 20;
 443       if (env_tables[i]->dsc$w_length == 12 &&
 444           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 445           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 446       flags = defflags | CLI$M_NOLOGNAM;
 447     }
 448     else {
 449       strcpy(cmd,"Show Logical *");
 450       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 451         strcat(cmd," /Table=");
 452         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 453         cmddsc.dsc$w_length = strlen(cmd);
 454       }
 455       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 456       flags = defflags | CLI$M_NOCLISYM;
 457     }
 458
 459     /* Create a new subprocess to execute each command, to exclude the
 460      * remote possibility that someone could subvert a mbx or file used
 461      * to write multiple commands to a single subprocess.
 462      */
 463     do {
 464       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 465                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 466       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 467       defflags &= ~CLI$M_TRUSTED;
 468     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 469     _ckvmssts(retsts);
 470     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
 471     if (seenhv) SvREFCNT_dec(seenhv);
 472     seenhv = newHV();
 473     while (1) {
 474       char *cp1, *cp2, *key;
 475       unsigned long int sts, iosb[2], retlen, keylen;
 476       register U32 hash;
 477
 478       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 479       if (sts & 1) sts = iosb[0] & 0xffff;
 480       if (sts == SS$_ENDOFFILE) {
 481         int wakect = 0;
 482         while (substs == 0) { sys$hiber(); wakect++;}
 483         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 484         _ckvmssts(substs);
 485         break;
 486       }
 487       _ckvmssts(sts);
 488       retlen = iosb[0] >> 16;
 489       if (!retlen) continue;  /* blank line */
 490       buf[retlen] = '\0';
 491       if (iosb[1] != subpid) {
 492         if (iosb[1]) {
 493           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 494         }
 495         continue;
 496       }
 497       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 498         Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
 499
 500       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 501       if (*cp1 == '(' || /* Logical name table name */
 502           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 503       if (*cp1 == '"') cp1++;
 504       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 505       key = cp1;  keylen = cp2 - cp1;
 506       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 507       while (*cp2 && *cp2 != '=') cp2++;
 508       while (*cp2 && *cp2 == '=') cp2++;
 509       while (*cp2 && *cp2 == ' ') cp2++;
 510       if (*cp2 == '"') {  /* String translation; may embed "" */
 511         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 512         cp2++;  cp1--; /* Skip "" surrounding translation */
 513       }
 514       else {  /* Numeric translation */
 515         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 516         cp1--;  /* stop on last non-space char */
 517       }
 518       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 519         Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
 520         continue;
 521       }
 522       PERL_HASH(hash,key,keylen);
 523       hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
 524       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 525     }
 526     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 527       /* get the PPFs for this process, not the subprocess */
 528       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 529       char eqv[LNM$C_NAMLENGTH+1];
 530       int trnlen, i;
 531       for (i = 0; ppfs[i]; i++) {
 532         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 533         hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
 534       }
 535     }
 536   }
 537   primed = 1;
 538   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 539   if (buf) Safefree(buf);
 540   if (seenhv) SvREFCNT_dec(seenhv);
 541   MUTEX_UNLOCK(&primenv_mutex);
 542   return;
 543
 544 }  /* end of prime_env_iter */
 545 /*}}}*/
 546
 547
 548 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
 549 /* Define or delete an element in the same "environment" as
 550  * vmstrnenv().  If an element is to be deleted, it's removed from
 551  * the first place it's found.  If it's to be set, it's set in the
 552  * place designated by the first element of the table vector.
 553  * Like setenv() returns 0 for success, non-zero on error.
 554  */
 555 int
 556 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 557 {
 558     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 559     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 560     unsigned long int retsts, usermode = PSL$C_USER;
 561     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 562                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 563                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 564     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 565     $DESCRIPTOR(local,"_LOCAL");
 566     dTHX;
 567
 568     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 569       *cp2 = _toupper(*cp1);
 570       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 571         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 572         return SS$_IVLOGNAM;
 573       }
 574     }
 575     lnmdsc.dsc$w_length = cp1 - lnm;
 576     if (!tabvec || !*tabvec) tabvec = env_tables;
 577
 578     if (!eqv) {  /* we're deleting n element */
 579       for (curtab = 0; tabvec[curtab]; curtab++) {
 580         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 581         int i;
 582           for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
 583             if ((cp1 = strchr(environ[i],'=')) &&
 584                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 585 #ifdef HAS_SETENV
 586               return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 587             }
 588           }
 589           ivenv = 1; retsts = SS$_NOLOGNAM;
 590 #else
 591               if (ckWARN(WARN_INTERNAL))
 592                 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
 593               ivenv = 1; retsts = SS$_NOSUCHPGM;
 594               break;
 595             }
 596           }
 597 #endif
 598         }
 599         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 600                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 601           unsigned int symtype;
 602           if (tabvec[curtab]->dsc$w_length == 12 &&
 603               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 604               !str$case_blind_compare(&tmpdsc,&local))
 605             symtype = LIB$K_CLI_LOCAL_SYM;
 606           else symtype = LIB$K_CLI_GLOBAL_SYM;
 607           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 608           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 609           if (retsts == LIB$_NOSUCHSYM) continue;
 610           break;
 611         }
 612         else if (!ivlnm) {
 613           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 614           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 615           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 616           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 617           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 618         }
 619       }
 620     }
 621     else {  /* we're defining a value */
 622       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 623 #ifdef HAS_SETENV
 624         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 625 #else
 626         if (ckWARN(WARN_INTERNAL))
 627           Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 628         retsts = SS$_NOSUCHPGM;
 629 #endif
 630       }
 631       else {
 632         eqvdsc.dsc$a_pointer = eqv;
 633         eqvdsc.dsc$w_length  = strlen(eqv);
 634         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 635             !str$case_blind_compare(&tmpdsc,&clisym)) {
 636           unsigned int symtype;
 637           if (tabvec[0]->dsc$w_length == 12 &&
 638               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 639                !str$case_blind_compare(&tmpdsc,&local))
 640             symtype = LIB$K_CLI_LOCAL_SYM;
 641           else symtype = LIB$K_CLI_GLOBAL_SYM;
 642           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 643         }
 644         else {
 645           if (!*eqv) eqvdsc.dsc$w_length = 1;
 646           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 647             eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
 648             if (ckWARN(WARN_MISC)) {
 649               Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
 650             }
 651           }
 652           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
 653         }
 654       }
 655     }
 656     if (!(retsts & 1)) {
 657       switch (retsts) {
 658         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
 659         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
 660           set_errno(EVMSERR); break;
 661         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
 662         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
 663           set_errno(EINVAL); break;
 664         case SS$_NOPRIV:
 665           set_errno(EACCES);
 666         default:
 667           _ckvmssts(retsts);
 668           set_errno(EVMSERR);
 669        }
 670        set_vaxc_errno(retsts);
 671        return (int) retsts || 44; /* retsts should never be 0, but just in case */
 672     }
 673     else {
 674       /* We reset error values on success because Perl does an hv_fetch()
 675        * before each hv_store(), and if the thing we're setting didn't
 676        * previously exist, we've got a leftover error message.  (Of course,
 677        * this fails in the face of
 678        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
 679        * in that the error reported in $! isn't spurious,
 680        * but it's right more often than not.)
 681        */
 682       set_errno(0); set_vaxc_errno(retsts);
 683       return 0;
 684     }
 685
 686 }  /* end of vmssetenv() */
 687 /*}}}*/
 688
 689 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 690 /* This has to be a function since there's a prototype for it in proto.h */
 691 void
 692 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 693 {
 694   if (lnm && *lnm && strlen(lnm) == 7) {
 695     char uplnm[8];
 696     int i;
 697     for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 698     if (!strcmp(uplnm,"DEFAULT")) {
 699       if (eqv && *eqv) chdir(eqv);
 700       return;
 701     }
 702   }
 703   (void) vmssetenv(lnm,eqv,NULL);
 704 }
 705 /*}}}*/
 706
 707
 708
 709 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 710 /* my_crypt - VMS password hashing
 711  * my_crypt() provides an interface compatible with the Unix crypt()
 712  * C library function, and uses sys$hash_password() to perform VMS
 713  * password hashing.  The quadword hashed password value is returned
 714  * as a NUL-terminated 8 character string.  my_crypt() does not change
 715  * the case of its string arguments; in order to match the behavior
 716  * of LOGINOUT et al., alphabetic characters in both arguments must
 717  *  be upcased by the caller.
 718  */
 719 char *
 720 my_crypt(const char *textpasswd, const char *usrname)
 721 {
 722 #   ifndef UAI$C_PREFERRED_ALGORITHM
 723 #     define UAI$C_PREFERRED_ALGORITHM 127
 724 #   endif
 725     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 726     unsigned short int salt = 0;
 727     unsigned long int sts;
 728     struct const_dsc {
 729         unsigned short int dsc$w_length;
 730         unsigned char      dsc$b_type;
 731         unsigned char      dsc$b_class;
 732         const char *       dsc$a_pointer;
 733     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 734        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 735     struct itmlst_3 uailst[3] = {
 736         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 737         { sizeof salt, UAI$_SALT,    &salt, 0},
 738         { 0,           0,            NULL,  NULL}};
 739     static char hash[9];
 740
 741     usrdsc.dsc$w_length = strlen(usrname);
 742     usrdsc.dsc$a_pointer = usrname;
 743     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 744       switch (sts) {
 745         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
 746           set_errno(EACCES);
 747           break;
 748         case RMS$_RNF:
 749           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 750           break;
 751         default:
 752           set_errno(EVMSERR);
 753       }
 754       set_vaxc_errno(sts);
 755       if (sts != RMS$_RNF) return NULL;
 756     }
 757
 758     txtdsc.dsc$w_length = strlen(textpasswd);
 759     txtdsc.dsc$a_pointer = textpasswd;
 760     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 761       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 762     }
 763
 764     return (char *) hash;
 765
 766 }  /* end of my_crypt() */
 767 /*}}}*/
 768
 769
 770 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
 771 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
 772 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
 773
 774 /*{{{int do_rmdir(char *name)*/
 775 int
 776 Perl_do_rmdir(pTHX_ char *name)
 777 {
 778     char dirfile[NAM$C_MAXRSS+1];
 779     int retval;
 780     Stat_t st;
 781
 782     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 783     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 784     else retval = kill_file(dirfile);
 785     return retval;
 786
 787 }  /* end of do_rmdir */
 788 /*}}}*/
 789
 790 /* kill_file
 791  * Delete any file to which user has control access, regardless of whether
 792  * delete access is explicitly allowed.
 793  * Limitations: User must have write access to parent directory.
 794  *              Does not block signals or ASTs; if interrupted in midstream
 795  *              may leave file with an altered ACL.
 796  * HANDLE WITH CARE!
 797  */
 798 /*{{{int kill_file(char *name)*/
 799 int
 800 kill_file(char *name)
 801 {
 802     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
 803     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 804     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 805     dTHX;
 806     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 807     struct myacedef {
 808       unsigned char myace$b_length;
 809       unsigned char myace$b_type;
 810       unsigned short int myace$w_flags;
 811       unsigned long int myace$l_access;
 812       unsigned long int myace$l_ident;
 813     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 814                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 815       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 816      struct itmlst_3
 817        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 818                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 819        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 820        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 821        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 822        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 823
 824     /* Expand the input spec using RMS, since the CRTL remove() and
 825      * system services won't do this by themselves, so we may miss
 826      * a file "hiding" behind a logical name or search list. */
 827     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 828     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
 829     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
 830     /* If not, can changing protections help? */
 831     if (vaxc$errno != RMS$_PRV) return -1;
 832
 833     /* No, so we get our own UIC to use as a rights identifier,
 834      * and the insert an ACE at the head of the ACL which allows us
 835      * to delete the file.
 836      */
 837     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 838     fildsc.dsc$w_length = strlen(rspec);
 839     fildsc.dsc$a_pointer = rspec;
 840     cxt = 0;
 841     newace.myace$l_ident = oldace.myace$l_ident;
 842     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 843       switch (aclsts) {
 844         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
 845           set_errno(ENOENT); break;
 846         case RMS$_DIR:
 847           set_errno(ENOTDIR); break;
 848         case RMS$_DEV:
 849           set_errno(ENODEV); break;
 850         case RMS$_SYN: case SS$_INVFILFOROP:
 851           set_errno(EINVAL); break;
 852         case RMS$_PRV:
 853           set_errno(EACCES); break;
 854         default:
 855           _ckvmssts(aclsts);
 856       }
 857       set_vaxc_errno(aclsts);
 858       return -1;
 859     }
 860     /* Grab any existing ACEs with this identifier in case we fail */
 861     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 862     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 863                     || fndsts == SS$_NOMOREACE ) {
 864       /* Add the new ACE . . . */
 865       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 866         goto yourroom;
 867       if ((rmsts = remove(name))) {
 868         /* We blew it - dir with files in it, no write priv for
 869          * parent directory, etc.  Put things back the way they were. */
 870         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 871           goto yourroom;
 872         if (fndsts & 1) {
 873           addlst[0].bufadr = &oldace;
 874           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 875             goto yourroom;
 876         }
 877       }
 878     }
 879
 880     yourroom:
 881     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 882     /* We just deleted it, so of course it's not there.  Some versions of
 883      * VMS seem to return success on the unlock operation anyhow (after all
 884      * the unlock is successful), but others don't.
 885      */
 886     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
 887     if (aclsts & 1) aclsts = fndsts;
 888     if (!(aclsts & 1)) {
 889       set_errno(EVMSERR);
 890       set_vaxc_errno(aclsts);
 891       return -1;
 892     }
 893
 894     return rmsts;
 895
 896 }  /* end of kill_file() */
 897 /*}}}*/
 898
 899
 900 /*{{{int my_mkdir(char *,Mode_t)*/
 901 int
 902 my_mkdir(char *dir, Mode_t mode)
 903 {
 904   STRLEN dirlen = strlen(dir);
 905   dTHX;
 906
 907   /* zero length string sometimes gives ACCVIO */
 908   if (dirlen == 0) return -1;
 909
 910   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
 911    * null file name/type.  However, it's commonplace under Unix,
 912    * so we'll allow it for a gain in portability.
 913    */
 914   if (dir[dirlen-1] == '/') {
 915     char *newdir = savepvn(dir,dirlen-1);
 916     int ret = mkdir(newdir,mode);
 917     Safefree(newdir);
 918     return ret;
 919   }
 920   else return mkdir(dir,mode);
 921 }  /* end of my_mkdir */
 922 /*}}}*/
 923
 924 /*{{{int my_chdir(char *)*/
 925 int
 926 my_chdir(char *dir)
 927 {
 928   STRLEN dirlen = strlen(dir);
 929   dTHX;
 930
 931   /* zero length string sometimes gives ACCVIO */
 932   if (dirlen == 0) return -1;
 933
 934   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
 935    * that implies
 936    * null file name/type.  However, it's commonplace under Unix,
 937    * so we'll allow it for a gain in portability.
 938    */
 939   if (dir[dirlen-1] == '/') {
 940     char *newdir = savepvn(dir,dirlen-1);
 941     int ret = chdir(newdir);
 942     Safefree(newdir);
 943     return ret;
 944   }
 945   else return chdir(dir);
 946 }  /* end of my_chdir */
 947 /*}}}*/
 948
 949
 950 /*{{{FILE *my_tmpfile()*/
 951 FILE *
 952 my_tmpfile(void)
 953 {
 954   FILE *fp;
 955   char *cp;
 956   dTHX;
 957
 958   if ((fp = tmpfile())) return fp;
 959
 960   New(1323,cp,L_tmpnam+24,char);
 961   strcpy(cp,"Sys$Scratch:");
 962   tmpnam(cp+strlen(cp));
 963   strcat(cp,".Perltmp");
 964   fp = fopen(cp,"w+","fop=dlt");
 965   Safefree(cp);
 966   return fp;
 967 }
 968 /*}}}*/
 969
 970
 971 static void
 972 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 973 {
 974   static unsigned long int mbxbufsiz;
 975   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 976   dTHX;
 977
 978   if (!mbxbufsiz) {
 979     /*
 980      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
 981      * preprocessor consant BUFSIZ from stdio.h as the size of the
 982      * 'pipe' mailbox.
 983      */
 984     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 985     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
 986   }
 987   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
 988
 989   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
 990   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
 991
 992 }  /* end of create_mbx() */
 993
 994 /*{{{  my_popen and my_pclose*/
 995 struct pipe_details
 996 {
 997     struct pipe_details *next;
 998     PerlIO *fp;  /* stdio file pointer to pipe mailbox */
 999     int pid;   /* PID of subprocess */
1000     int mode;  /* == 'r' if pipe open for reading */
1001     int done;  /* subprocess has completed */
1002     unsigned long int completion;  /* termination status of subprocess */
1003 };
1004
1005 struct exit_control_block
1006 {
1007     struct exit_control_block *flink;
1008     unsigned long int   (*exit_routine)();
1009     unsigned long int arg_count;
1010     unsigned long int *status_address;
1011     unsigned long int exit_status;
1012 };
1013
1014 static struct pipe_details *open_pipes = NULL;
1015 static $DESCRIPTOR(nl_desc, "NL:");
1016 static int waitpid_asleep = 0;
1017
1018 /* Send an EOF to a mbx.  N.B.  We don't check that fp actually points
1019  * to a mbx; that's the caller's responsibility.
1020  */
1021 static unsigned long int
1022 pipe_eof(FILE *fp, int immediate)
1023 {
1024   char devnam[NAM$C_MAXRSS+1], *cp;
1025   unsigned long int chan, iosb[2], retsts, retsts2;
1026   struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
1027   dTHX;
1028
1029   if (fgetname(fp,devnam,1)) {
1030     /* It oughta be a mailbox, so fgetname should give just the device
1031      * name, but just in case . . . */
1032     if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
1033     devdsc.dsc$w_length = strlen(devnam);
1034     _ckvmssts(sys$assign(&devdsc,&chan,0,0));
1035     retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
1036              iosb,0,0,0,0,0,0,0,0);
1037     if (retsts & 1) retsts = iosb[0];
1038     retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
1039     if (retsts & 1) retsts = retsts2;
1040     _ckvmssts(retsts);
1041     return retsts;
1042   }
1043   else _ckvmssts(vaxc$errno);  /* Should never happen */
1044   return (unsigned long int) vaxc$errno;
1045 }
1046
1047 static unsigned long int
1048 pipe_exit_routine()
1049 {
1050     struct pipe_details *info;
1051     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1052     int sts, did_stuff;
1053     dTHX;
1054
1055     /*
1056      first we try sending an EOF...ignore if doesn't work, make sure we
1057      don't hang
1058     */
1059     did_stuff = 0;
1060     info = open_pipes;
1061
1062     while (info) {
1063       int need_eof;
1064       _ckvmssts(sys$setast(0));
1065       need_eof = info->mode != 'r' && !info->done;
1066       _ckvmssts(sys$setast(1));
1067       if (need_eof) {
1068         if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1069       }
1070       info = info->next;
1071     }
1072     if (did_stuff) sleep(1);   /* wait for EOF to have an effect */
1073
1074     did_stuff = 0;
1075     info = open_pipes;
1076     while (info) {
1077       _ckvmssts(sys$setast(0));
1078       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1079         sts = sys$forcex(&info->pid,0,&abort);
1080         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1081         did_stuff = 1;
1082       }
1083       _ckvmssts(sys$setast(1));
1084       info = info->next;
1085     }
1086     if (did_stuff) sleep(1);    /* wait for them to respond */
1087
1088     info = open_pipes;
1089     while (info) {
1090       _ckvmssts(sys$setast(0));
1091       if (!info->done) {  /* We tried to be nice . . . */
1092         sts = sys$delprc(&info->pid,0);
1093         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1094         info->done = 1; /* so my_pclose doesn't try to write EOF */
1095       }
1096       _ckvmssts(sys$setast(1));
1097       info = info->next;
1098     }
1099
1100     while(open_pipes) {
1101       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1102       else if (!(sts & 1)) retsts = sts;
1103     }
1104     return retsts;
1105 }
1106
1107 static struct exit_control_block pipe_exitblock =
1108        {(struct exit_control_block *) 0,
1109         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1110
1111
1112 static void
1113 popen_completion_ast(struct pipe_details *thispipe)
1114 {
1115   thispipe->done = TRUE;
1116   if (waitpid_asleep) {
1117     waitpid_asleep = 0;
1118     sys$wake(0,0);
1119   }
1120 }
1121
1122 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1123 static void vms_execfree(pTHX);
1124
1125 static PerlIO *
1126 safe_popen(char *cmd, char *mode)
1127 {
1128     static int handler_set_up = FALSE;
1129     char mbxname[64];
1130     unsigned short int chan;
1131     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
1132     dTHX;
1133     struct pipe_details *info;
1134     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1135                                       DSC$K_CLASS_S, mbxname},
1136                             cmddsc = {0, DSC$K_DTYPE_T,
1137                                       DSC$K_CLASS_S, 0};
1138
1139
1140     if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1141     New(1301,info,1,struct pipe_details);
1142
1143     /* create mailbox */
1144     create_mbx(&chan,&namdsc);
1145
1146     /* open a FILE* onto it */
1147     info->fp = PerlIO_open(mbxname, mode);
1148
1149     /* give up other channel onto it */
1150     _ckvmssts(sys$dassgn(chan));
1151
1152     if (!info->fp)
1153         return Nullfp;
1154
1155     info->mode = *mode;
1156     info->done = FALSE;
1157     info->completion=0;
1158
1159     if (*mode == 'r') {
1160       _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1161                      0  /* name */, &info->pid, &info->completion,
1162                      0, popen_completion_ast,info,0,0,0));
1163     }
1164     else {
1165       _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1166                      0  /* name */, &info->pid, &info->completion,
1167                      0, popen_completion_ast,info,0,0,0));
1168     }
1169
1170     vms_execfree(aTHX);
1171     if (!handler_set_up) {
1172       _ckvmssts(sys$dclexh(&pipe_exitblock));
1173       handler_set_up = TRUE;
1174     }
1175     info->next=open_pipes;  /* prepend to list */
1176     open_pipes=info;
1177
1178     PL_forkprocess = info->pid;
1179     return info->fp;
1180 }  /* end of safe_popen */
1181
1182
1183 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
1184 FILE *
1185 Perl_my_popen(pTHX_ char *cmd, char *mode)
1186 {
1187     TAINT_ENV();
1188     TAINT_PROPER("popen");
1189     PERL_FLUSHALL_FOR_CHILD;
1190     return safe_popen(cmd,mode);
1191 }
1192
1193 /*}}}*/
1194
1195 /*{{{  I32 my_pclose(FILE *fp)*/
1196 I32 Perl_my_pclose(pTHX_ FILE *fp)
1197 {
1198     struct pipe_details *info, *last = NULL;
1199     unsigned long int retsts;
1200     int need_eof;
1201
1202     for (info = open_pipes; info != NULL; last = info, info = info->next)
1203         if (info->fp == fp) break;
1204
1205     if (info == NULL) {  /* no such pipe open */
1206       set_errno(ECHILD); /* quoth POSIX */
1207       set_vaxc_errno(SS$_NONEXPR);
1208       return -1;
1209     }
1210
1211     /* If we were writing to a subprocess, insure that someone reading from
1212      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
1213      * produce an EOF record in the mailbox.  */
1214     _ckvmssts(sys$setast(0));
1215     need_eof = info->mode != 'r' && !info->done;
1216     _ckvmssts(sys$setast(1));
1217     if (need_eof) pipe_eof(info->fp,0);
1218     PerlIO_close(info->fp);
1219
1220     if (info->done) retsts = info->completion;
1221     else waitpid(info->pid,(int *) &retsts,0);
1222
1223     /* remove from list of open pipes */
1224     _ckvmssts(sys$setast(0));
1225     if (last) last->next = info->next;
1226     else open_pipes = info->next;
1227     _ckvmssts(sys$setast(1));
1228     Safefree(info);
1229
1230     return retsts;
1231
1232 }  /* end of my_pclose() */
1233
1234 /* sort-of waitpid; use only with popen() */
1235 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1236 Pid_t
1237 my_waitpid(Pid_t pid, int *statusp, int flags)
1238 {
1239     struct pipe_details *info;
1240     dTHX;
1241
1242     for (info = open_pipes; info != NULL; info = info->next)
1243         if (info->pid == pid) break;
1244
1245     if (info != NULL) {  /* we know about this child */
1246       while (!info->done) {
1247         waitpid_asleep = 1;
1248         sys$hiber();
1249       }
1250
1251       *statusp = info->completion;
1252       return pid;
1253     }
1254     else {  /* we haven't heard of this child */
1255       $DESCRIPTOR(intdsc,"0 00:00:01");
1256       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1257       unsigned long int interval[2],sts;
1258
1259       if (ckWARN(WARN_EXEC)) {
1260         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1261         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1262         if (ownerpid != mypid)
1263           Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1264       }
1265
1266       _ckvmssts(sys$bintim(&intdsc,interval));
1267       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1268         _ckvmssts(sys$schdwk(0,0,interval,0));
1269         _ckvmssts(sys$hiber());
1270       }
1271       _ckvmssts(sts);
1272
1273       /* There's no easy way to find the termination status a child we're
1274        * not aware of beforehand.  If we're really interested in the future,
1275        * we can go looking for a termination mailbox, or chase after the
1276        * accounting record for the process.
1277        */
1278       *statusp = 0;
1279       return pid;
1280     }
1281
1282 }  /* end of waitpid() */
1283 /*}}}*/
1284 /*}}}*/
1285 /*}}}*/
1286
1287 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1288 char *
1289 my_gconvert(double val, int ndig, int trail, char *buf)
1290 {
1291   static char __gcvtbuf[DBL_DIG+1];
1292   char *loc;
1293
1294   loc = buf ? buf : __gcvtbuf;
1295
1296 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
1297   if (val < 1) {
1298     sprintf(loc,"%.*g",ndig,val);
1299     return loc;
1300   }
1301 #endif
1302
1303   if (val) {
1304     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1305     return gcvt(val,ndig,loc);
1306   }
1307   else {
1308     loc[0] = '0'; loc[1] = '\0';
1309     return loc;
1310   }
1311
1312 }
1313 /*}}}*/
1314
1315
1316 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1317 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1318  * to expand file specification.  Allows for a single default file
1319  * specification and a simple mask of options.  If outbuf is non-NULL,
1320  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1321  * the resultant file specification is placed.  If outbuf is NULL, the
1322  * resultant file specification is placed into a static buffer.
1323  * The third argument, if non-NULL, is taken to be a default file
1324  * specification string.  The fourth argument is unused at present.
1325  * rmesexpand() returns the address of the resultant string if
1326  * successful, and NULL on error.
1327  */
1328 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
1329
1330 static char *
1331 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1332 {
1333   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1334   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1335   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1336   struct FAB myfab = cc$rms_fab;
1337   struct NAM mynam = cc$rms_nam;
1338   STRLEN speclen;
1339   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1340
1341   if (!filespec || !*filespec) {
1342     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1343     return NULL;
1344   }
1345   if (!outbuf) {
1346     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1347     else    outbuf = __rmsexpand_retbuf;
1348   }
1349   if ((isunix = (strchr(filespec,'/') != NULL))) {
1350     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1351     filespec = vmsfspec;
1352   }
1353
1354   myfab.fab$l_fna = filespec;
1355   myfab.fab$b_fns = strlen(filespec);
1356   myfab.fab$l_nam = &mynam;
1357
1358   if (defspec && *defspec) {
1359     if (strchr(defspec,'/') != NULL) {
1360       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1361       defspec = tmpfspec;
1362     }
1363     myfab.fab$l_dna = defspec;
1364     myfab.fab$b_dns = strlen(defspec);
1365   }
1366
1367   mynam.nam$l_esa = esa;
1368   mynam.nam$b_ess = sizeof esa;
1369   mynam.nam$l_rsa = outbuf;
1370   mynam.nam$b_rss = NAM$C_MAXRSS;
1371
1372   retsts = sys$parse(&myfab,0,0);
1373   if (!(retsts & 1)) {
1374     mynam.nam$b_nop |= NAM$M_SYNCHK;
1375     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
1376       retsts = sys$parse(&myfab,0,0);
1377       if (retsts & 1) goto expanded;
1378     }
1379     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1380     (void) sys$parse(&myfab,0,0);  /* Free search context */
1381     if (out) Safefree(out);
1382     set_vaxc_errno(retsts);
1383     if      (retsts == RMS$_PRV) set_errno(EACCES);
1384     else if (retsts == RMS$_DEV) set_errno(ENODEV);
1385     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1386     else                         set_errno(EVMSERR);
1387     return NULL;
1388   }
1389   retsts = sys$search(&myfab,0,0);
1390   if (!(retsts & 1) && retsts != RMS$_FNF) {
1391     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1392     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
1393     if (out) Safefree(out);
1394     set_vaxc_errno(retsts);
1395     if      (retsts == RMS$_PRV) set_errno(EACCES);
1396     else                         set_errno(EVMSERR);
1397     return NULL;
1398   }
1399
1400   /* If the input filespec contained any lowercase characters,
1401    * downcase the result for compatibility with Unix-minded code. */
1402   expanded:
1403   for (out = myfab.fab$l_fna; *out; out++)
1404     if (islower(*out)) { haslower = 1; break; }
1405   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1406   else                 { out = esa;    speclen = mynam.nam$b_esl; }
1407   /* Trim off null fields added by $PARSE
1408    * If type > 1 char, must have been specified in original or default spec
1409    * (not true for version; $SEARCH may have added version of existing file).
1410    */
1411   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1412   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1413              (mynam.nam$l_ver - mynam.nam$l_type == 1);
1414   if (trimver || trimtype) {
1415     if (defspec && *defspec) {
1416       char defesa[NAM$C_MAXRSS];
1417       struct FAB deffab = cc$rms_fab;
1418       struct NAM defnam = cc$rms_nam;
1419
1420       deffab.fab$l_nam = &defnam;
1421       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
1422       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
1423       defnam.nam$b_nop = NAM$M_SYNCHK;
1424       if (sys$parse(&deffab,0,0) & 1) {
1425         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1426         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1427       }
1428     }
1429     if (trimver) speclen = mynam.nam$l_ver - out;
1430     if (trimtype) {
1431       /* If we didn't already trim version, copy down */
1432       if (speclen > mynam.nam$l_ver - out)
1433         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1434                speclen - (mynam.nam$l_ver - out));
1435       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1436     }
1437   }
1438   /* If we just had a directory spec on input, $PARSE "helpfully"
1439    * adds an empty name and type for us */
1440   if (mynam.nam$l_name == mynam.nam$l_type &&
1441       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
1442       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1443     speclen = mynam.nam$l_name - out;
1444   out[speclen] = '\0';
1445   if (haslower) __mystrtolower(out);
1446
1447   /* Have we been working with an expanded, but not resultant, spec? */
1448   /* Also, convert back to Unix syntax if necessary. */
1449   if (!mynam.nam$b_rsl) {
1450     if (isunix) {
1451       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1452     }
1453     else strcpy(outbuf,esa);
1454   }
1455   else if (isunix) {
1456     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1457     strcpy(outbuf,tmpfspec);
1458   }
1459   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1460   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1461   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
1462   return outbuf;
1463 }
1464 /*}}}*/
1465 /* External entry points */
1466 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1467 { return do_rmsexpand(spec,buf,0,def,opt); }
1468 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1469 { return do_rmsexpand(spec,buf,1,def,opt); }
1470
1471
1472 /*
1473 ** The following routines are provided to make life easier when
1474 ** converting among VMS-style and Unix-style directory specifications.
1475 ** All will take input specifications in either VMS or Unix syntax. On
1476 ** failure, all return NULL.  If successful, the routines listed below
1477 ** return a pointer to a buffer containing the appropriately
1478 ** reformatted spec (and, therefore, subsequent calls to that routine
1479 ** will clobber the result), while the routines of the same names with
1480 ** a _ts suffix appended will return a pointer to a mallocd string
1481 ** containing the appropriately reformatted spec.
1482 ** In all cases, only explicit syntax is altered; no check is made that
1483 ** the resulting string is valid or that the directory in question
1484 ** actually exists.
1485 **
1486 **   fileify_dirspec() - convert a directory spec into the name of the
1487 **     directory file (i.e. what you can stat() to see if it's a dir).
1488 **     The style (VMS or Unix) of the result is the same as the style
1489 **     of the parameter passed in.
1490 **   pathify_dirspec() - convert a directory spec into a path (i.e.
1491 **     what you prepend to a filename to indicate what directory it's in).
1492 **     The style (VMS or Unix) of the result is the same as the style
1493 **     of the parameter passed in.
1494 **   tounixpath() - convert a directory spec into a Unix-style path.
1495 **   tovmspath() - convert a directory spec into a VMS-style path.
1496 **   tounixspec() - convert any file spec into a Unix-style file spec.
1497 **   tovmsspec() - convert any file spec into a VMS-style spec.
1498 **
1499 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
1500 ** Permission is given to distribute this code as part of the Perl
1501 ** standard distribution under the terms of the GNU General Public
1502 ** License or the Perl Artistic License.  Copies of each may be
1503 ** found in the Perl standard distribution.
1504  */
1505
1506 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1507 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
1508 {
1509     static char __fileify_retbuf[NAM$C_MAXRSS+1];
1510     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1511     char *retspec, *cp1, *cp2, *lastdir;
1512     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1513
1514     if (!dir || !*dir) {
1515       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1516     }
1517     dirlen = strlen(dir);
1518     while (dirlen && dir[dirlen-1] == '/') --dirlen;
1519     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1520       strcpy(trndir,"/sys$disk/000000");
1521       dir = trndir;
1522       dirlen = 16;
1523     }
1524     if (dirlen > NAM$C_MAXRSS) {
1525       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1526     }
1527     if (!strpbrk(dir+1,"/]>:")) {
1528       strcpy(trndir,*dir == '/' ? dir + 1: dir);
1529       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1530       dir = trndir;
1531       dirlen = strlen(dir);
1532     }
1533     else {
1534       strncpy(trndir,dir,dirlen);
1535       trndir[dirlen] = '\0';
1536       dir = trndir;
1537     }
1538     /* If we were handed a rooted logical name or spec, treat it like a
1539      * simple directory, so that
1540      *    $ Define myroot dev:[dir.]
1541      *    ... do_fileify_dirspec("myroot",buf,1) ...
1542      * does something useful.
1543      */
1544     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
1545       dir[--dirlen] = '\0';
1546       dir[dirlen-1] = ']';
1547     }
1548
1549     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1550       /* If we've got an explicit filename, we can just shuffle the string. */
1551       if (*(cp1+1)) hasfilename = 1;
1552       /* Similarly, we can just back up a level if we've got multiple levels
1553          of explicit directories in a VMS spec which ends with directories. */
1554       else {
1555         for (cp2 = cp1; cp2 > dir; cp2--) {
1556           if (*cp2 == '.') {
1557             *cp2 = *cp1; *cp1 = '\0';
1558             hasfilename = 1;
1559             break;
1560           }
1561           if (*cp2 == '[' || *cp2 == '<') break;
1562         }
1563       }
1564     }
1565
1566     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1567       if (dir[0] == '.') {
1568         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1569           return do_fileify_dirspec("[]",buf,ts);
1570         else if (dir[1] == '.' &&
1571                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1572           return do_fileify_dirspec("[-]",buf,ts);
1573       }
1574       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
1575         dirlen -= 1;                 /* to last element */
1576         lastdir = strrchr(dir,'/');
1577       }
1578       else if ((cp1 = strstr(dir,"/.")) != NULL) {
1579         /* If we have "/." or "/..", VMSify it and let the VMS code
1580          * below expand it, rather than repeating the code to handle
1581          * relative components of a filespec here */
1582         do {
1583           if (*(cp1+2) == '.') cp1++;
1584           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1585             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1586             if (strchr(vmsdir,'/') != NULL) {
1587               /* If do_tovmsspec() returned it, it must have VMS syntax
1588                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
1589                * the time to check this here only so we avoid a recursion
1590                * loop; otherwise, gigo.
1591                */
1592               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
1593             }
1594             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1595             return do_tounixspec(trndir,buf,ts);
1596           }
1597           cp1++;
1598         } while ((cp1 = strstr(cp1,"/.")) != NULL);
1599         lastdir = strrchr(dir,'/');
1600       }
1601       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
1602         /* Ditto for specs that end in an MFD -- let the VMS code
1603          * figure out whether it's a real device or a rooted logical. */
1604         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1605         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1606         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1607         return do_tounixspec(trndir,buf,ts);
1608       }
1609       else {
1610         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1611              !(lastdir = cp1 = strrchr(dir,']')) &&
1612              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1613         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
1614           int ver; char *cp3;
1615           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1616               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1617               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1618               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1619               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1620                             (ver || *cp3)))))) {
1621             set_errno(ENOTDIR);
1622             set_vaxc_errno(RMS$_DIR);
1623             return NULL;
1624           }
1625           dirlen = cp2 - dir;
1626         }
1627       }
1628       /* If we lead off with a device or rooted logical, add the MFD
1629          if we're specifying a top-level directory. */
1630       if (lastdir && *dir == '/') {
1631         addmfd = 1;
1632         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1633           if (*cp1 == '/') {
1634             addmfd = 0;
1635             break;
1636           }
1637         }
1638       }
1639       retlen = dirlen + (addmfd ? 13 : 6);
1640       if (buf) retspec = buf;
1641       else if (ts) New(1309,retspec,retlen+1,char);
1642       else retspec = __fileify_retbuf;
1643       if (addmfd) {
1644         dirlen = lastdir - dir;
1645         memcpy(retspec,dir,dirlen);
1646         strcpy(&retspec[dirlen],"/000000");
1647         strcpy(&retspec[dirlen+7],lastdir);
1648       }
1649       else {
1650         memcpy(retspec,dir,dirlen);
1651         retspec[dirlen] = '\0';
1652       }
1653       /* We've picked up everything up to the directory file name.
1654          Now just add the type and version, and we're set. */
1655       strcat(retspec,".dir;1");
1656       return retspec;
1657     }
1658     else {  /* VMS-style directory spec */
1659       char esa[NAM$C_MAXRSS+1], term, *cp;
1660       unsigned long int sts, cmplen, haslower = 0;
1661       struct FAB dirfab = cc$rms_fab;
1662       struct NAM savnam, dirnam = cc$rms_nam;
1663
1664       dirfab.fab$b_fns = strlen(dir);
1665       dirfab.fab$l_fna = dir;
1666       dirfab.fab$l_nam = &dirnam;
1667       dirfab.fab$l_dna = ".DIR;1";
1668       dirfab.fab$b_dns = 6;
1669       dirnam.nam$b_ess = NAM$C_MAXRSS;
1670       dirnam.nam$l_esa = esa;
1671
1672       for (cp = dir; *cp; cp++)
1673         if (islower(*cp)) { haslower = 1; break; }
1674       if (!((sts = sys$parse(&dirfab))&1)) {
1675         if (dirfab.fab$l_sts == RMS$_DIR) {
1676           dirnam.nam$b_nop |= NAM$M_SYNCHK;
1677           sts = sys$parse(&dirfab) & 1;
1678         }
1679         if (!sts) {
1680           set_errno(EVMSERR);
1681           set_vaxc_errno(dirfab.fab$l_sts);
1682           return NULL;
1683         }
1684       }
1685       else {
1686         savnam = dirnam;
1687         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
1688           /* Yes; fake the fnb bits so we'll check type below */
1689           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1690         }
1691         else { /* No; just work with potential name */
1692           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1693           else {
1694             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
1695             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1696             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1697             return NULL;
1698           }
1699         }
1700       }
1701       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1702         cp1 = strchr(esa,']');
1703         if (!cp1) cp1 = strchr(esa,'>');
1704         if (cp1) {  /* Should always be true */
1705           dirnam.nam$b_esl -= cp1 - esa - 1;
1706           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1707         }
1708       }
1709       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1710         /* Yep; check version while we're at it, if it's there. */
1711         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1712         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1713           /* Something other than .DIR[;1].  Bzzt. */
1714           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1715           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1716           set_errno(ENOTDIR);
1717           set_vaxc_errno(RMS$_DIR);
1718           return NULL;
1719         }
1720       }
1721       esa[dirnam.nam$b_esl] = '\0';
1722       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1723         /* They provided at least the name; we added the type, if necessary, */
1724         if (buf) retspec = buf;                            /* in sys$parse() */
1725         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1726         else retspec = __fileify_retbuf;
1727         strcpy(retspec,esa);
1728         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1729         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1730         return retspec;
1731       }
1732       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1733         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1734         *cp1 = '\0';
1735         dirnam.nam$b_esl -= 9;
1736       }
1737       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1738       if (cp1 == NULL) { /* should never happen */
1739         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1740         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1741         return NULL;
1742       }
1743       term = *cp1;
1744       *cp1 = '\0';
1745       retlen = strlen(esa);
1746       if ((cp1 = strrchr(esa,'.')) != NULL) {
1747         /* There's more than one directory in the path.  Just roll back. */
1748         *cp1 = term;
1749         if (buf) retspec = buf;
1750         else if (ts) New(1311,retspec,retlen+7,char);
1751         else retspec = __fileify_retbuf;
1752         strcpy(retspec,esa);
1753       }
1754       else {
1755         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1756           /* Go back and expand rooted logical name */
1757           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1758           if (!(sys$parse(&dirfab) & 1)) {
1759             dirnam.nam$l_rlf = NULL;
1760             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1761             set_errno(EVMSERR);
1762             set_vaxc_errno(dirfab.fab$l_sts);
1763             return NULL;
1764           }
1765           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1766           if (buf) retspec = buf;
1767           else if (ts) New(1312,retspec,retlen+16,char);
1768           else retspec = __fileify_retbuf;
1769           cp1 = strstr(esa,"][");
1770           dirlen = cp1 - esa;
1771           memcpy(retspec,esa,dirlen);
1772           if (!strncmp(cp1+2,"000000]",7)) {
1773             retspec[dirlen-1] = '\0';
1774             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1775             if (*cp1 == '.') *cp1 = ']';
1776             else {
1777               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1778               memcpy(cp1+1,"000000]",7);
1779             }
1780           }
1781           else {
1782             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1783             retspec[retlen] = '\0';
1784             /* Convert last '.' to ']' */
1785             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1786             if (*cp1 == '.') *cp1 = ']';
1787             else {
1788               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1789               memcpy(cp1+1,"000000]",7);
1790             }
1791           }
1792         }
1793         else {  /* This is a top-level dir.  Add the MFD to the path. */
1794           if (buf) retspec = buf;
1795           else if (ts) New(1312,retspec,retlen+16,char);
1796           else retspec = __fileify_retbuf;
1797           cp1 = esa;
1798           cp2 = retspec;
1799           while (*cp1 != ':') *(cp2++) = *(cp1++);
1800           strcpy(cp2,":[000000]");
1801           cp1 += 2;
1802           strcpy(cp2+9,cp1);
1803         }
1804       }
1805       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1806       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1807       /* We've set up the string up through the filename.  Add the
1808          type and version, and we're done. */
1809       strcat(retspec,".DIR;1");
1810
1811       /* $PARSE may have upcased filespec, so convert output to lower
1812        * case if input contained any lowercase characters. */
1813       if (haslower) __mystrtolower(retspec);
1814       return retspec;
1815     }
1816 }  /* end of do_fileify_dirspec() */
1817 /*}}}*/
1818 /* External entry points */
1819 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
1820 { return do_fileify_dirspec(dir,buf,0); }
1821 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
1822 { return do_fileify_dirspec(dir,buf,1); }
1823
1824 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1825 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
1826 {
1827     static char __pathify_retbuf[NAM$C_MAXRSS+1];
1828     unsigned long int retlen;
1829     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1830
1831     if (!dir || !*dir) {
1832       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1833     }
1834
1835     if (*dir) strcpy(trndir,dir);
1836     else getcwd(trndir,sizeof trndir - 1);
1837
1838     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1839            && my_trnlnm(trndir,trndir,0)) {
1840       STRLEN trnlen = strlen(trndir);
1841
1842       /* Trap simple rooted lnms, and return lnm:[000000] */
1843       if (!strcmp(trndir+trnlen-2,".]")) {
1844         if (buf) retpath = buf;
1845         else if (ts) New(1318,retpath,strlen(dir)+10,char);
1846         else retpath = __pathify_retbuf;
1847         strcpy(retpath,dir);
1848         strcat(retpath,":[000000]");
1849         return retpath;
1850       }
1851     }
1852     dir = trndir;
1853
1854     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1855       if (*dir == '.' && (*(dir+1) == '\0' ||
1856                           (*(dir+1) == '.' && *(dir+2) == '\0')))
1857         retlen = 2 + (*(dir+1) != '\0');
1858       else {
1859         if ( !(cp1 = strrchr(dir,'/')) &&
1860              !(cp1 = strrchr(dir,']')) &&
1861              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1862         if ((cp2 = strchr(cp1,'.')) != NULL &&
1863             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
1864              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
1865               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1866               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1867           int ver; char *cp3;
1868           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1869               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1870               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1871               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1872               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1873                             (ver || *cp3)))))) {
1874             set_errno(ENOTDIR);
1875             set_vaxc_errno(RMS$_DIR);
1876             return NULL;
1877           }
1878           retlen = cp2 - dir + 1;
1879         }
1880         else {  /* No file type present.  Treat the filename as a directory. */
1881           retlen = strlen(dir) + 1;
1882         }
1883       }
1884       if (buf) retpath = buf;
1885       else if (ts) New(1313,retpath,retlen+1,char);
1886       else retpath = __pathify_retbuf;
1887       strncpy(retpath,dir,retlen-1);
1888       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1889         retpath[retlen-1] = '/';      /* with '/', add it. */
1890         retpath[retlen] = '\0';
1891       }
1892       else retpath[retlen-1] = '\0';
1893     }
1894     else {  /* VMS-style directory spec */
1895       char esa[NAM$C_MAXRSS+1], *cp;
1896       unsigned long int sts, cmplen, haslower;
1897       struct FAB dirfab = cc$rms_fab;
1898       struct NAM savnam, dirnam = cc$rms_nam;
1899
1900       /* If we've got an explicit filename, we can just shuffle the string. */
1901       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1902              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
1903         if ((cp2 = strchr(cp1,'.')) != NULL) {
1904           int ver; char *cp3;
1905           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
1906               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
1907               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1908               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
1909               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1910                             (ver || *cp3)))))) {
1911             set_errno(ENOTDIR);
1912             set_vaxc_errno(RMS$_DIR);
1913             return NULL;
1914           }
1915         }
1916         else {  /* No file type, so just draw name into directory part */
1917           for (cp2 = cp1; *cp2; cp2++) ;
1918         }
1919         *cp2 = *cp1;
1920         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
1921         *cp1 = '.';
1922         /* We've now got a VMS 'path'; fall through */
1923       }
1924       dirfab.fab$b_fns = strlen(dir);
1925       dirfab.fab$l_fna = dir;
1926       if (dir[dirfab.fab$b_fns-1] == ']' ||
1927           dir[dirfab.fab$b_fns-1] == '>' ||
1928           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1929         if (buf) retpath = buf;
1930         else if (ts) New(1314,retpath,strlen(dir)+1,char);
1931         else retpath = __pathify_retbuf;
1932         strcpy(retpath,dir);
1933         return retpath;
1934       }
1935       dirfab.fab$l_dna = ".DIR;1";
1936       dirfab.fab$b_dns = 6;
1937       dirfab.fab$l_nam = &dirnam;
1938       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1939       dirnam.nam$l_esa = esa;
1940
1941       for (cp = dir; *cp; cp++)
1942         if (islower(*cp)) { haslower = 1; break; }
1943
1944       if (!(sts = (sys$parse(&dirfab)&1))) {
1945         if (dirfab.fab$l_sts == RMS$_DIR) {
1946           dirnam.nam$b_nop |= NAM$M_SYNCHK;
1947           sts = sys$parse(&dirfab) & 1;
1948         }
1949         if (!sts) {
1950           set_errno(EVMSERR);
1951           set_vaxc_errno(dirfab.fab$l_sts);
1952           return NULL;
1953         }
1954       }
1955       else {
1956         savnam = dirnam;
1957         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
1958           if (dirfab.fab$l_sts != RMS$_FNF) {
1959             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1960             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1961             set_errno(EVMSERR);
1962             set_vaxc_errno(dirfab.fab$l_sts);
1963             return NULL;
1964           }
1965           dirnam = savnam; /* No; just work with potential name */
1966         }
1967       }
1968       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1969         /* Yep; check version while we're at it, if it's there. */
1970         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1971         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1972           /* Something other than .DIR[;1].  Bzzt. */
1973           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1974           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1975           set_errno(ENOTDIR);
1976           set_vaxc_errno(RMS$_DIR);
1977           return NULL;
1978         }
1979       }
1980       /* OK, the type was fine.  Now pull any file name into the
1981          directory path. */
1982       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1983       else {
1984         cp1 = strrchr(esa,'>');
1985         *dirnam.nam$l_type = '>';
1986       }
1987       *cp1 = '.';
1988       *(dirnam.nam$l_type + 1) = '\0';
1989       retlen = dirnam.nam$l_type - esa + 2;
1990       if (buf) retpath = buf;
1991       else if (ts) New(1314,retpath,retlen,char);
1992       else retpath = __pathify_retbuf;
1993       strcpy(retpath,esa);
1994       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
1995       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
1996       /* $PARSE may have upcased filespec, so convert output to lower
1997        * case if input contained any lowercase characters. */
1998       if (haslower) __mystrtolower(retpath);
1999     }
2000
2001     return retpath;
2002 }  /* end of do_pathify_dirspec() */
2003 /*}}}*/
2004 /* External entry points */
2005 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2006 { return do_pathify_dirspec(dir,buf,0); }
2007 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
2008 { return do_pathify_dirspec(dir,buf,1); }
2009
2010 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
2011 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
2012 {
2013   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
2014   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
2015   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
2016
2017   if (spec == NULL) return NULL;
2018   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
2019   if (buf) rslt = buf;
2020   else if (ts) {
2021     retlen = strlen(spec);
2022     cp1 = strchr(spec,'[');
2023     if (!cp1) cp1 = strchr(spec,'<');
2024     if (cp1) {
2025       for (cp1++; *cp1; cp1++) {
2026         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
2027         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2028           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2029       }
2030     }
2031     New(1315,rslt,retlen+2+2*expand,char);
2032   }
2033   else rslt = __tounixspec_retbuf;
2034   if (strchr(spec,'/') != NULL) {
2035     strcpy(rslt,spec);
2036     return rslt;
2037   }
2038
2039   cp1 = rslt;
2040   cp2 = spec;
2041   dirend = strrchr(spec,']');
2042   if (dirend == NULL) dirend = strrchr(spec,'>');
2043   if (dirend == NULL) dirend = strchr(spec,':');
2044   if (dirend == NULL) {
2045     strcpy(rslt,spec);
2046     return rslt;
2047   }
2048   if (*cp2 != '[' && *cp2 != '<') {
2049     *(cp1++) = '/';
2050   }
2051   else {  /* the VMS spec begins with directories */
2052     cp2++;
2053     if (*cp2 == ']' || *cp2 == '>') {
2054       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2055       return rslt;
2056     }
2057     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2058       if (getcwd(tmp,sizeof tmp,1) == NULL) {
2059         if (ts) Safefree(rslt);
2060         return NULL;
2061       }
2062       do {
2063         cp3 = tmp;
2064         while (*cp3 != ':' && *cp3) cp3++;
2065         *(cp3++) = '\0';
2066         if (strchr(cp3,']') != NULL) break;
2067       } while (vmstrnenv(tmp,tmp,0,fildev,0));
2068       if (ts && !buf &&
2069           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2070         retlen = devlen + dirlen;
2071         Renew(rslt,retlen+1+2*expand,char);
2072         cp1 = rslt;
2073       }
2074       cp3 = tmp;
2075       *(cp1++) = '/';
2076       while (*cp3) {
2077         *(cp1++) = *(cp3++);
2078         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2079       }
2080       *(cp1++) = '/';
2081     }
2082     else if ( *cp2 == '.') {
2083       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2084         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2085         cp2 += 3;
2086       }
2087       else cp2++;
2088     }
2089   }
2090   for (; cp2 <= dirend; cp2++) {
2091     if (*cp2 == ':') {
2092       *(cp1++) = '/';
2093       if (*(cp2+1) == '[') cp2++;
2094     }
2095     else if (*cp2 == ']' || *cp2 == '>') {
2096       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2097     }
2098     else if (*cp2 == '.') {
2099       *(cp1++) = '/';
2100       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2101         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2102                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2103         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2104             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2105       }
2106       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2107         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2108         cp2 += 2;
2109       }
2110     }
2111     else if (*cp2 == '-') {
2112       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2113         while (*cp2 == '-') {
2114           cp2++;
2115           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2116         }
2117         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2118           if (ts) Safefree(rslt);                        /* filespecs like */
2119           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
2120           return NULL;
2121         }
2122       }
2123       else *(cp1++) = *cp2;
2124     }
2125     else *(cp1++) = *cp2;
2126   }
2127   while (*cp2) *(cp1++) = *(cp2++);
2128   *cp1 = '\0';
2129
2130   return rslt;
2131
2132 }  /* end of do_tounixspec() */
2133 /*}}}*/
2134 /* External entry points */
2135 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2136 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2137
2138 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2139 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
2140   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2141   char *rslt, *dirend;
2142   register char *cp1, *cp2;
2143   unsigned long int infront = 0, hasdir = 1;
2144
2145   if (path == NULL) return NULL;
2146   if (buf) rslt = buf;
2147   else if (ts) New(1316,rslt,strlen(path)+9,char);
2148   else rslt = __tovmsspec_retbuf;
2149   if (strpbrk(path,"]:>") ||
2150       (dirend = strrchr(path,'/')) == NULL) {
2151     if (path[0] == '.') {
2152       if (path[1] == '\0') strcpy(rslt,"[]");
2153       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2154       else strcpy(rslt,path); /* probably garbage */
2155     }
2156     else strcpy(rslt,path);
2157     return rslt;
2158   }
2159   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
2160     if (!*(dirend+2)) dirend +=2;
2161     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2162     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2163   }
2164   cp1 = rslt;
2165   cp2 = path;
2166   if (*cp2 == '/') {
2167     char trndev[NAM$C_MAXRSS+1];
2168     int islnm, rooted;
2169     STRLEN trnend;
2170
2171     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
2172     if (!*(cp2+1)) {
2173       if (!buf & ts) Renew(rslt,18,char);
2174       strcpy(rslt,"sys$disk:[000000]");
2175       return rslt;
2176     }
2177     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2178     *cp1 = '\0';
2179     islnm =  my_trnlnm(rslt,trndev,0);
2180     trnend = islnm ? strlen(trndev) - 1 : 0;
2181     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2182     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2183     /* If the first element of the path is a logical name, determine
2184      * whether it has to be translated so we can add more directories. */
2185     if (!islnm || rooted) {
2186       *(cp1++) = ':';
2187       *(cp1++) = '[';
2188       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2189       else cp2++;
2190     }
2191     else {
2192       if (cp2 != dirend) {
2193         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2194         strcpy(rslt,trndev);
2195         cp1 = rslt + trnend;
2196         *(cp1++) = '.';
2197         cp2++;
2198       }
2199       else {
2200         *(cp1++) = ':';
2201         hasdir = 0;
2202       }
2203     }
2204   }
2205   else {
2206     *(cp1++) = '[';
2207     if (*cp2 == '.') {
2208       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2209         cp2 += 2;         /* skip over "./" - it's redundant */
2210         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
2211       }
2212       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2213         *(cp1++) = '-';                                 /* "../" --> "-" */
2214         cp2 += 3;
2215       }
2216       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2217                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2218         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2219         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2220         cp2 += 4;
2221       }
2222       if (cp2 > dirend) cp2 = dirend;
2223     }
2224     else *(cp1++) = '.';
2225   }
2226   for (; cp2 < dirend; cp2++) {
2227     if (*cp2 == '/') {
2228       if (*(cp2-1) == '/') continue;
2229       if (*(cp1-1) != '.') *(cp1++) = '.';
2230       infront = 0;
2231     }
2232     else if (!infront && *cp2 == '.') {
2233       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2234       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
2235       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2236         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2237         else if (*(cp1-2) == '[') *(cp1-1) = '-';
2238         else {  /* back up over previous directory name */
2239           cp1--;
2240           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2241           if (*(cp1-1) == '[') {
2242             memcpy(cp1,"000000.",7);
2243             cp1 += 7;
2244           }
2245         }
2246         cp2 += 2;
2247         if (cp2 == dirend) break;
2248       }
2249       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2250                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2251         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2252         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2253         if (!*(cp2+3)) {
2254           *(cp1++) = '.';  /* Simulate trailing '/' */
2255           cp2 += 2;  /* for loop will incr this to == dirend */
2256         }
2257         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
2258       }
2259       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
2260     }
2261     else {
2262       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
2263       if (*cp2 == '.')      *(cp1++) = '_';
2264       else                  *(cp1++) =  *cp2;
2265       infront = 1;
2266     }
2267   }
2268   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2269   if (hasdir) *(cp1++) = ']';
2270   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
2271   while (*cp2) *(cp1++) = *(cp2++);
2272   *cp1 = '\0';
2273
2274   return rslt;
2275
2276 }  /* end of do_tovmsspec() */
2277 /*}}}*/
2278 /* External entry points */
2279 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2280 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2281
2282 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2283 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
2284   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2285   int vmslen;
2286   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2287
2288   if (path == NULL) return NULL;
2289   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2290   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2291   if (buf) return buf;
2292   else if (ts) {
2293     vmslen = strlen(vmsified);
2294     New(1317,cp,vmslen+1,char);
2295     memcpy(cp,vmsified,vmslen);
2296     cp[vmslen] = '\0';
2297     return cp;
2298   }
2299   else {
2300     strcpy(__tovmspath_retbuf,vmsified);
2301     return __tovmspath_retbuf;
2302   }
2303
2304 }  /* end of do_tovmspath() */
2305 /*}}}*/
2306 /* External entry points */
2307 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
2308 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
2309
2310
2311 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2312 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
2313   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2314   int unixlen;
2315   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2316
2317   if (path == NULL) return NULL;
2318   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2319   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2320   if (buf) return buf;
2321   else if (ts) {
2322     unixlen = strlen(unixified);
2323     New(1317,cp,unixlen+1,char);
2324     memcpy(cp,unixified,unixlen);
2325     cp[unixlen] = '\0';
2326     return cp;
2327   }
2328   else {
2329     strcpy(__tounixpath_retbuf,unixified);
2330     return __tounixpath_retbuf;
2331   }
2332
2333 }  /* end of do_tounixpath() */
2334 /*}}}*/
2335 /* External entry points */
2336 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
2337 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
2338
2339 /*
2340  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
2341  *
2342  *****************************************************************************
2343  *                                                                           *
2344  *  Copyright (C) 1989-1994 by                                               *
2345  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
2346  *                                                                           *
2347  *  Permission is hereby  granted for the reproduction of this software,     *
2348  *  on condition that this copyright notice is included in the reproduction, *
2349  *  and that such reproduction is not for purposes of profit or material     *
2350  *  gain.                                                                    *
2351  *                                                                           *
2352  *  27-Aug-1994 Modified for inclusion in perl5                              *
2353  *              by Charles Bailey  bailey@newman.upenn.edu                   *
2354  *****************************************************************************
2355  */
2356
2357 /*
2358  * getredirection() is intended to aid in porting C programs
2359  * to VMS (Vax-11 C).  The native VMS environment does not support
2360  * '>' and '<' I/O redirection, or command line wild card expansion,
2361  * or a command line pipe mechanism using the '|' AND background
2362  * command execution '&'.  All of these capabilities are provided to any
2363  * C program which calls this procedure as the first thing in the
2364  * main program.
2365  * The piping mechanism will probably work with almost any 'filter' type
2366  * of program.  With suitable modification, it may useful for other
2367  * portability problems as well.
2368  *
2369  * Author:  Mark Pizzolato      mark@infocomm.com
2370  */
2371 struct list_item
2372     {
2373     struct list_item *next;
2374     char *value;
2375     };
2376
2377 static void add_item(struct list_item **head,
2378                      struct list_item **tail,
2379                      char *value,
2380                      int *count);
2381
2382 static void mp_expand_wild_cards(pTHX_ char *item,
2383                                 struct list_item **head,
2384                                 struct list_item **tail,
2385                                 int *count);
2386
2387 static int background_process(int argc, char **argv);
2388
2389 static void pipe_and_fork(char **cmargv);
2390
2391 /*{{{ void getredirection(int *ac, char ***av)*/
2392 static void
2393 mp_getredirection(pTHX_ int *ac, char ***av)
2394 /*
2395  * Process vms redirection arg's.  Exit if any error is seen.
2396  * If getredirection() processes an argument, it is erased
2397  * from the vector.  getredirection() returns a new argc and argv value.
2398  * In the event that a background command is requested (by a trailing "&"),
2399  * this routine creates a background subprocess, and simply exits the program.
2400  *
2401  * Warning: do not try to simplify the code for vms.  The code
2402  * presupposes that getredirection() is called before any data is
2403  * read from stdin or written to stdout.
2404  *
2405  * Normal usage is as follows:
2406  *
2407  *      main(argc, argv)
2408  *      int             argc;
2409  *      char            *argv[];
2410  *      {
2411  *              getredirection(&argc, &argv);
2412  *      }
2413  */
2414 {
2415     int                 argc = *ac;     /* Argument Count         */
2416     char                **argv = *av;   /* Argument Vector        */
2417     char                *ap;            /* Argument pointer       */
2418     int                 j;              /* argv[] index           */
2419     int                 item_count = 0; /* Count of Items in List */
2420     struct list_item    *list_head = 0; /* First Item in List       */
2421     struct list_item    *list_tail;     /* Last Item in List        */
2422     char                *in = NULL;     /* Input File Name          */
2423     char                *out = NULL;    /* Output File Name         */
2424     char                *outmode = "w"; /* Mode to Open Output File */
2425     char                *err = NULL;    /* Error File Name          */
2426     char                *errmode = "w"; /* Mode to Open Error File  */
2427     int                 cmargc = 0;     /* Piped Command Arg Count  */
2428     char                **cmargv = NULL;/* Piped Command Arg Vector */
2429
2430     /*
2431      * First handle the case where the last thing on the line ends with
2432      * a '&'.  This indicates the desire for the command to be run in a
2433      * subprocess, so we satisfy that desire.
2434      */
2435     ap = argv[argc-1];
2436     if (0 == strcmp("&", ap))
2437         exit(background_process(--argc, argv));
2438     if (*ap && '&' == ap[strlen(ap)-1])
2439         {
2440         ap[strlen(ap)-1] = '\0';
2441         exit(background_process(argc, argv));
2442         }
2443     /*
2444      * Now we handle the general redirection cases that involve '>', '>>',
2445      * '<', and pipes '|'.
2446      */
2447     for (j = 0; j < argc; ++j)
2448         {
2449         if (0 == strcmp("<", argv[j]))
2450             {
2451             if (j+1 >= argc)
2452                 {
2453                 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2454                 exit(LIB$_WRONUMARG);
2455                 }
2456             in = argv[++j];
2457             continue;
2458             }
2459         if ('<' == *(ap = argv[j]))
2460             {
2461             in = 1 + ap;
2462             continue;
2463             }
2464         if (0 == strcmp(">", ap))
2465             {
2466             if (j+1 >= argc)
2467                 {
2468                 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2469                 exit(LIB$_WRONUMARG);
2470                 }
2471             out = argv[++j];
2472             continue;
2473             }
2474         if ('>' == *ap)
2475             {
2476             if ('>' == ap[1])
2477                 {
2478                 outmode = "a";
2479                 if ('\0' == ap[2])
2480                     out = argv[++j];
2481                 else
2482                     out = 2 + ap;
2483                 }
2484             else
2485                 out = 1 + ap;
2486             if (j >= argc)
2487                 {
2488                 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2489                 exit(LIB$_WRONUMARG);
2490                 }
2491             continue;
2492             }
2493         if (('2' == *ap) && ('>' == ap[1]))
2494             {
2495             if ('>' == ap[2])
2496                 {
2497                 errmode = "a";
2498                 if ('\0' == ap[3])
2499                     err = argv[++j];
2500                 else
2501                     err = 3 + ap;
2502                 }
2503             else
2504                 if ('\0' == ap[2])
2505                     err = argv[++j];
2506                 else
2507                     err = 2 + ap;
2508             if (j >= argc)
2509                 {
2510                 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2511                 exit(LIB$_WRONUMARG);
2512                 }
2513             continue;
2514             }
2515         if (0 == strcmp("|", argv[j]))
2516             {
2517             if (j+1 >= argc)
2518                 {
2519                 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2520                 exit(LIB$_WRONUMARG);
2521                 }
2522             cmargc = argc-(j+1);
2523             cmargv = &argv[j+1];
2524             argc = j;
2525             continue;
2526             }
2527         if ('|' == *(ap = argv[j]))
2528             {
2529             ++argv[j];
2530             cmargc = argc-j;
2531             cmargv = &argv[j];
2532             argc = j;
2533             continue;
2534             }
2535         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2536         }
2537     /*
2538      * Allocate and fill in the new argument vector, Some Unix's terminate
2539      * the list with an extra null pointer.
2540      */
2541     New(1302, argv, item_count+1, char *);
2542     *av = argv;
2543     for (j = 0; j < item_count; ++j, list_head = list_head->next)
2544         argv[j] = list_head->value;
2545     *ac = item_count;
2546     if (cmargv != NULL)
2547         {
2548         if (out != NULL)
2549             {
2550             PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2551             exit(LIB$_INVARGORD);
2552             }
2553         pipe_and_fork(cmargv);
2554         }
2555
2556     /* Check for input from a pipe (mailbox) */
2557
2558     if (in == NULL && 1 == isapipe(0))
2559         {
2560         char mbxname[L_tmpnam];
2561         long int bufsize;
2562         long int dvi_item = DVI$_DEVBUFSIZ;
2563         $DESCRIPTOR(mbxnam, "");
2564         $DESCRIPTOR(mbxdevnam, "");
2565
2566         /* Input from a pipe, reopen it in binary mode to disable       */
2567         /* carriage control processing.                                 */
2568
2569         PerlIO_getname(stdin, mbxname);
2570         mbxnam.dsc$a_pointer = mbxname;
2571         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2572         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2573         mbxdevnam.dsc$a_pointer = mbxname;
2574         mbxdevnam.dsc$w_length = sizeof(mbxname);
2575         dvi_item = DVI$_DEVNAM;
2576         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2577         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2578         set_errno(0);
2579         set_vaxc_errno(1);
2580         freopen(mbxname, "rb", stdin);
2581         if (errno != 0)
2582             {
2583             PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2584             exit(vaxc$errno);
2585             }
2586         }
2587     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2588         {
2589         PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2590         exit(vaxc$errno);
2591         }
2592     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2593         {
2594         PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2595         exit(vaxc$errno);
2596         }
2597     if (err != NULL) {
2598         if (strcmp(err,"&1") == 0) {
2599             dup2(fileno(stdout), fileno(Perl_debug_log));
2600         } else {
2601         FILE *tmperr;
2602         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2603             {
2604             PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2605             exit(vaxc$errno);
2606             }
2607             fclose(tmperr);
2608             if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2609                 {
2610                 exit(vaxc$errno);
2611                 }
2612         }
2613         }
2614 #ifdef ARGPROC_DEBUG
2615     PerlIO_printf(Perl_debug_log, "Arglist:\n");
2616     for (j = 0; j < *ac;  ++j)
2617         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2618 #endif
2619    /* Clear errors we may have hit expanding wildcards, so they don't
2620       show up in Perl's $! later */
2621    set_errno(0); set_vaxc_errno(1);
2622 }  /* end of getredirection() */
2623 /*}}}*/
2624
2625 static void add_item(struct list_item **head,
2626                      struct list_item **tail,
2627                      char *value,
2628                      int *count)
2629 {
2630     if (*head == 0)
2631         {
2632         New(1303,*head,1,struct list_item);
2633         *tail = *head;
2634         }
2635     else {
2636         New(1304,(*tail)->next,1,struct list_item);
2637         *tail = (*tail)->next;
2638         }
2639     (*tail)->value = value;
2640     ++(*count);
2641 }
2642
2643 static void mp_expand_wild_cards(pTHX_ char *item,
2644                               struct list_item **head,
2645                               struct list_item **tail,
2646                               int *count)
2647 {
2648 int expcount = 0;
2649 unsigned long int context = 0;
2650 int isunix = 0;
2651 char *had_version;
2652 char *had_device;
2653 int had_directory;
2654 char *devdir,*cp;
2655 char vmsspec[NAM$C_MAXRSS+1];
2656 $DESCRIPTOR(filespec, "");
2657 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2658 $DESCRIPTOR(resultspec, "");
2659 unsigned long int zero = 0, sts;
2660
2661     for (cp = item; *cp; cp++) {
2662         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2663         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2664     }
2665     if (!*cp || isspace(*cp))
2666         {
2667         add_item(head, tail, item, count);
2668         return;
2669         }
2670     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2671     resultspec.dsc$b_class = DSC$K_CLASS_D;
2672     resultspec.dsc$a_pointer = NULL;
2673     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2674       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2675     if (!isunix || !filespec.dsc$a_pointer)
2676       filespec.dsc$a_pointer = item;
2677     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2678     /*
2679      * Only return version specs, if the caller specified a version
2680      */
2681     had_version = strchr(item, ';');
2682     /*
2683      * Only return device and directory specs, if the caller specifed either.
2684      */
2685     had_device = strchr(item, ':');
2686     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2687
2688     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2689                                   &defaultspec, 0, 0, &zero))))
2690         {
2691         char *string;
2692         char *c;
2693
2694         New(1305,string,resultspec.dsc$w_length+1,char);
2695         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2696         string[resultspec.dsc$w_length] = '\0';
2697         if (NULL == had_version)
2698             *((char *)strrchr(string, ';')) = '\0';
2699         if ((!had_directory) && (had_device == NULL))
2700             {
2701             if (NULL == (devdir = strrchr(string, ']')))
2702                 devdir = strrchr(string, '>');
2703             strcpy(string, devdir + 1);
2704             }
2705         /*
2706          * Be consistent with what the C RTL has already done to the rest of
2707          * the argv items and lowercase all of these names.
2708          */
2709         for (c = string; *c; ++c)
2710             if (isupper(*c))
2711                 *c = tolower(*c);
2712         if (isunix) trim_unixpath(string,item,1);
2713         add_item(head, tail, string, count);
2714         ++expcount;
2715         }
2716     if (sts != RMS$_NMF)
2717         {
2718         set_vaxc_errno(sts);
2719         switch (sts)
2720             {
2721             case RMS$_FNF: case RMS$_DNF:
2722                 set_errno(ENOENT); break;
2723             case RMS$_DIR:
2724                 set_errno(ENOTDIR); break;
2725             case RMS$_DEV:
2726                 set_errno(ENODEV); break;
2727             case RMS$_FNM: case RMS$_SYN:
2728                 set_errno(EINVAL); break;
2729             case RMS$_PRV:
2730                 set_errno(EACCES); break;
2731             default:
2732                 _ckvmssts_noperl(sts);
2733             }
2734         }
2735     if (expcount == 0)
2736         add_item(head, tail, item, count);
2737     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2738     _ckvmssts_noperl(lib$find_file_end(&context));
2739 }
2740
2741 static int child_st[2];/* Event Flag set when child process completes   */
2742
2743 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
2744
2745 static unsigned long int exit_handler(int *status)
2746 {
2747 short iosb[4];
2748
2749     if (0 == child_st[0])
2750         {
2751 #ifdef ARGPROC_DEBUG
2752         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2753 #endif
2754         fflush(stdout);     /* Have to flush pipe for binary data to    */
2755                             /* terminate properly -- <tp@mccall.com>    */
2756         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2757         sys$dassgn(child_chan);
2758         fclose(stdout);
2759         sys$synch(0, child_st);
2760         }
2761     return(1);
2762 }
2763
2764 static void sig_child(int chan)
2765 {
2766 #ifdef ARGPROC_DEBUG
2767     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2768 #endif
2769     if (child_st[0] == 0)
2770         child_st[0] = 1;
2771 }
2772
2773 static struct exit_control_block exit_block =
2774     {
2775     0,
2776     exit_handler,
2777     1,
2778     &exit_block.exit_status,
2779     0
2780     };
2781
2782 static void pipe_and_fork(char **cmargv)
2783 {
2784     char subcmd[2048];
2785     $DESCRIPTOR(cmddsc, "");
2786     static char mbxname[64];
2787     $DESCRIPTOR(mbxdsc, mbxname);
2788     int pid, j;
2789     unsigned long int zero = 0, one = 1;
2790
2791     strcpy(subcmd, cmargv[0]);
2792     for (j = 1; NULL != cmargv[j]; ++j)
2793         {
2794         strcat(subcmd, " \"");
2795         strcat(subcmd, cmargv[j]);
2796         strcat(subcmd, "\"");
2797         }
2798     cmddsc.dsc$a_pointer = subcmd;
2799     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2800
2801         create_mbx(&child_chan,&mbxdsc);
2802 #ifdef ARGPROC_DEBUG
2803     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2804     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2805 #endif
2806     _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2807                                0, &pid, child_st, &zero, sig_child,
2808                                &child_chan));
2809 #ifdef ARGPROC_DEBUG
2810     PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2811 #endif
2812     sys$dclexh(&exit_block);
2813     if (NULL == freopen(mbxname, "wb", stdout))
2814         {
2815         PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2816         }
2817 }
2818
2819 static int background_process(int argc, char **argv)
2820 {
2821 char command[2048] = "$";
2822 $DESCRIPTOR(value, "");
2823 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2824 static $DESCRIPTOR(null, "NLA0:");
2825 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2826 char pidstring[80];
2827 $DESCRIPTOR(pidstr, "");
2828 int pid;
2829 unsigned long int flags = 17, one = 1, retsts;
2830
2831     strcat(command, argv[0]);
2832     while (--argc)
2833         {
2834         strcat(command, " \"");
2835         strcat(command, *(++argv));
2836         strcat(command, "\"");
2837         }
2838     value.dsc$a_pointer = command;
2839     value.dsc$w_length = strlen(value.dsc$a_pointer);
2840     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2841     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2842     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2843         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2844     }
2845     else {
2846         _ckvmssts_noperl(retsts);
2847     }
2848 #ifdef ARGPROC_DEBUG
2849     PerlIO_printf(Perl_debug_log, "%s\n", command);
2850 #endif
2851     sprintf(pidstring, "%08X", pid);
2852     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2853     pidstr.dsc$a_pointer = pidstring;
2854     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2855     lib$set_symbol(&pidsymbol, &pidstr);
2856     return(SS$_NORMAL);
2857 }
2858 /*}}}*/
2859 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2860
2861
2862 /* OS-specific initialization at image activation (not thread startup) */
2863 /* Older VAXC header files lack these constants */
2864 #ifndef JPI$_RIGHTS_SIZE
2865 #  define JPI$_RIGHTS_SIZE 817
2866 #endif
2867 #ifndef KGB$M_SUBSYSTEM
2868 #  define KGB$M_SUBSYSTEM 0x8
2869 #endif
2870
2871 /*{{{void vms_image_init(int *, char ***)*/
2872 void
2873 vms_image_init(int *argcp, char ***argvp)
2874 {
2875   char eqv[LNM$C_NAMLENGTH+1] = "";
2876   unsigned int len, tabct = 8, tabidx = 0;
2877   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2878   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2879   unsigned short int dummy, rlen;
2880   struct dsc$descriptor_s **tabvec;
2881   dTHX;
2882   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
2883                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
2884                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2885                                  {          0,                0,    0,      0} };
2886
2887   _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2888   _ckvmssts(iosb[0]);
2889   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2890     if (iprv[i]) {           /* Running image installed with privs? */
2891       _ckvmssts(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
2892       will_taint = TRUE;
2893       break;
2894     }
2895   }
2896   /* Rights identifiers might trigger tainting as well. */
2897   if (!will_taint && (rlen || rsz)) {
2898     while (rlen < rsz) {
2899       /* We didn't get all the identifiers on the first pass.  Allocate a
2900        * buffer much larger than $GETJPI wants (rsz is size in bytes that
2901        * were needed to hold all identifiers at time of last call; we'll
2902        * allocate that many unsigned long ints), and go back and get 'em.
2903        * If it gave us less than it wanted to despite ample buffer space,
2904        * something's broken.  Is your system missing a system identifier?
2905        */
2906       if (rsz <= jpilist[1].buflen) {
2907          /* Perl_croak accvios when used this early in startup. */
2908          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
2909                          rsz, (unsigned long) jpilist[1].buflen,
2910                          "Check your rights database for corruption.\n");
2911          exit(SS$_ABORT);
2912       }
2913       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2914       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2915       jpilist[1].buflen = rsz * sizeof(unsigned long int);
2916       _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2917       _ckvmssts(iosb[0]);
2918     }
2919     mask = jpilist[1].bufadr;
2920     /* Check attribute flags for each identifier (2nd longword); protected
2921      * subsystem identifiers trigger tainting.
2922      */
2923     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2924       if (mask[i] & KGB$M_SUBSYSTEM) {
2925         will_taint = TRUE;
2926         break;
2927       }
2928     }
2929     if (mask != rlst) Safefree(mask);
2930   }
2931   /* We need to use this hack to tell Perl it should run with tainting,
2932    * since its tainting flag may be part of the PL_curinterp struct, which
2933    * hasn't been allocated when vms_image_init() is called.
2934    */
2935   if (will_taint) {
2936     char ***newap;
2937     New(1320,newap,*argcp+2,char **);
2938     newap[0] = argvp[0];
2939     *newap[1] = "-T";
2940     Copy(argvp[1],newap[2],*argcp-1,char **);
2941     /* We orphan the old argv, since we don't know where it's come from,
2942      * so we don't know how to free it.
2943      */
2944     *argcp++; argvp = newap;
2945   }
2946   else {  /* Did user explicitly request tainting? */
2947     int i;
2948     char *cp, **av = *argvp;
2949     for (i = 1; i < *argcp; i++) {
2950       if (*av[i] != '-') break;
2951       for (cp = av[i]+1; *cp; cp++) {
2952         if (*cp == 'T') { will_taint = 1; break; }
2953         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2954                   strchr("DFIiMmx",*cp)) break;
2955       }
2956       if (will_taint) break;
2957     }
2958   }
2959
2960   for (tabidx = 0;
2961        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2962        tabidx++) {
2963     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2964     else if (tabidx >= tabct) {
2965       tabct += 8;
2966       Renew(tabvec,tabct,struct dsc$descriptor_s *);
2967     }
2968     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2969     tabvec[tabidx]->dsc$w_length  = 0;
2970     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
2971     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
2972     tabvec[tabidx]->dsc$a_pointer = NULL;
2973     _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2974   }
2975   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2976
2977   getredirection(argcp,argvp);
2978 #if defined(USE_THREADS) && defined(__DECC)
2979   {
2980 # include <reentrancy.h>
2981   (void) decc$set_reentrancy(C$C_MULTITHREAD);
2982   }
2983 #endif
2984   return;
2985 }
2986 /*}}}*/
2987
2988
2989 /* trim_unixpath()
2990  * Trim Unix-style prefix off filespec, so it looks like what a shell
2991  * glob expansion would return (i.e. from specified prefix on, not
2992  * full path).  Note that returned filespec is Unix-style, regardless
2993  * of whether input filespec was VMS-style or Unix-style.
2994  *
2995  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2996  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
2997  * vector of options; at present, only bit 0 is used, and if set tells
2998  * trim unixpath to try the current default directory as a prefix when
2999  * presented with a possibly ambiguous ... wildcard.
3000  *
3001  * Returns !=0 on success, with trimmed filespec replacing contents of
3002  * fspec, and 0 on failure, with contents of fpsec unchanged.
3003  */
3004 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
3005 int
3006 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
3007 {
3008   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3009        *template, *base, *end, *cp1, *cp2;
3010   register int tmplen, reslen = 0, dirs = 0;
3011
3012   if (!wildspec || !fspec) return 0;
3013   if (strpbrk(wildspec,"]>:") != NULL) {
3014     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3015     else template = unixwild;
3016   }
3017   else template = wildspec;
3018   if (strpbrk(fspec,"]>:") != NULL) {
3019     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3020     else base = unixified;
3021     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
3022      * check to see that final result fits into (isn't longer than) fspec */
3023     reslen = strlen(fspec);
3024   }
3025   else base = fspec;
3026
3027   /* No prefix or absolute path on wildcard, so nothing to remove */
3028   if (!*template || *template == '/') {
3029     if (base == fspec) return 1;
3030     tmplen = strlen(unixified);
3031     if (tmplen > reslen) return 0;  /* not enough space */
3032     /* Copy unixified resultant, including trailing NUL */
3033     memmove(fspec,unixified,tmplen+1);
3034     return 1;
3035   }
3036
3037   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
3038   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3039     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3040     for (cp1 = end ;cp1 >= base; cp1--)
3041       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3042         { cp1++; break; }
3043     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3044     return 1;
3045   }
3046   else {
3047     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3048     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3049     int ells = 1, totells, segdirs, match;
3050     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3051                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3052
3053     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3054     totells = ells;
3055     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3056     if (ellipsis == template && opts & 1) {
3057       /* Template begins with an ellipsis.  Since we can't tell how many
3058        * directory names at the front of the resultant to keep for an
3059        * arbitrary starting point, we arbitrarily choose the current
3060        * default directory as a starting point.  If it's there as a prefix,
3061        * clip it off.  If not, fall through and act as if the leading
3062        * ellipsis weren't there (i.e. return shortest possible path that
3063        * could match template).
3064        */
3065       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3066       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3067         if (_tolower(*cp1) != _tolower(*cp2)) break;
3068       segdirs = dirs - totells;  /* Min # of dirs we must have left */
3069       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3070       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3071         memcpy(fspec,cp2+1,end - cp2);
3072         return 1;
3073       }
3074     }
3075     /* First off, back up over constant elements at end of path */
3076     if (dirs) {
3077       for (front = end ; front >= base; front--)
3078          if (*front == '/' && !dirs--) { front++; break; }
3079     }
3080     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3081          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
3082     if (cp1 != '\0') return 0;  /* Path too long. */
3083     lcend = cp2;
3084     *cp2 = '\0';  /* Pick up with memcpy later */
3085     lcfront = lcres + (front - base);
3086     /* Now skip over each ellipsis and try to match the path in front of it. */
3087     while (ells--) {
3088       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3089         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
3090             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
3091       if (cp1 < template) break; /* template started with an ellipsis */
3092       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3093         ellipsis = cp1; continue;
3094       }
3095       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3096       nextell = cp1;
3097       for (segdirs = 0, cp2 = tpl;
3098            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3099            cp1++, cp2++) {
3100          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3101          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
3102          if (*cp2 == '/') segdirs++;
3103       }
3104       if (cp1 != ellipsis - 1) return 0; /* Path too long */
3105       /* Back up at least as many dirs as in template before matching */
3106       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3107         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3108       for (match = 0; cp1 > lcres;) {
3109         resdsc.dsc$a_pointer = cp1;
3110         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3111           match++;
3112           if (match == 1) lcfront = cp1;
3113         }
3114         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3115       }
3116       if (!match) return 0;  /* Can't find prefix ??? */
3117       if (match > 1 && opts & 1) {
3118         /* This ... wildcard could cover more than one set of dirs (i.e.
3119          * a set of similar dir names is repeated).  If the template
3120          * contains more than 1 ..., upstream elements could resolve the
3121          * ambiguity, but it's not worth a full backtracking setup here.
3122          * As a quick heuristic, clip off the current default directory
3123          * if it's present to find the trimmed spec, else use the
3124          * shortest string that this ... could cover.
3125          */
3126         char def[NAM$C_MAXRSS+1], *st;
3127
3128         if (getcwd(def, sizeof def,0) == NULL) return 0;
3129         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3130           if (_tolower(*cp1) != _tolower(*cp2)) break;
3131         segdirs = dirs - totells;  /* Min # of dirs we must have left */
3132         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3133         if (*cp1 == '\0' && *cp2 == '/') {
3134           memcpy(fspec,cp2+1,end - cp2);
3135           return 1;
3136         }
3137         /* Nope -- stick with lcfront from above and keep going. */
3138       }
3139     }
3140     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3141     return 1;
3142     ellipsis = nextell;
3143   }
3144
3145 }  /* end of trim_unixpath() */
3146 /*}}}*/
3147
3148
3149 /*
3150  *  VMS readdir() routines.
3151  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3152  *
3153  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
3154  *  Minor modifications to original routines.
3155  */
3156
3157     /* Number of elements in vms_versions array */
3158 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
3159
3160 /*
3161  *  Open a directory, return a handle for later use.
3162  */
3163 /*{{{ DIR *opendir(char*name) */
3164 DIR *
3165 Perl_opendir(pTHX_ char *name)
3166 {
3167     DIR *dd;
3168     char dir[NAM$C_MAXRSS+1];
3169     Stat_t sb;
3170
3171     if (do_tovmspath(name,dir,0) == NULL) {
3172       return NULL;
3173     }
3174     if (flex_stat(dir,&sb) == -1) return NULL;
3175     if (!S_ISDIR(sb.st_mode)) {
3176       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
3177       return NULL;
3178     }
3179     if (!cando_by_name(S_IRUSR,0,dir)) {
3180       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3181       return NULL;
3182     }
3183     /* Get memory for the handle, and the pattern. */
3184     New(1306,dd,1,DIR);
3185     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3186
3187     /* Fill in the fields; mainly playing with the descriptor. */
3188     (void)sprintf(dd->pattern, "%s*.*",dir);
3189     dd->context = 0;
3190     dd->count = 0;
3191     dd->vms_wantversions = 0;
3192     dd->pat.dsc$a_pointer = dd->pattern;
3193     dd->pat.dsc$w_length = strlen(dd->pattern);
3194     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3195     dd->pat.dsc$b_class = DSC$K_CLASS_S;
3196
3197     return dd;
3198 }  /* end of opendir() */
3199 /*}}}*/
3200
3201 /*
3202  *  Set the flag to indicate we want versions or not.
3203  */
3204 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3205 void
3206 vmsreaddirversions(DIR *dd, int flag)
3207 {
3208     dd->vms_wantversions = flag;
3209 }
3210 /*}}}*/
3211
3212 /*
3213  *  Free up an opened directory.
3214  */
3215 /*{{{ void closedir(DIR *dd)*/
3216 void
3217 closedir(DIR *dd)
3218 {
3219     (void)lib$find_file_end(&dd->context);
3220     Safefree(dd->pattern);
3221     Safefree((char *)dd);
3222 }
3223 /*}}}*/
3224
3225 /*
3226  *  Collect all the version numbers for the current file.
3227  */
3228 static void
3229 collectversions(dd)
3230     DIR *dd;
3231 {
3232     struct dsc$descriptor_s     pat;
3233     struct dsc$descriptor_s     res;
3234     struct dirent *e;
3235     char *p, *text, buff[sizeof dd->entry.d_name];
3236     int i;
3237     unsigned long context, tmpsts;
3238     dTHX;
3239
3240     /* Convenient shorthand. */
3241     e = &dd->entry;
3242
3243     /* Add the version wildcard, ignoring the "*.*" put on before */
3244     i = strlen(dd->pattern);
3245     New(1308,text,i + e->d_namlen + 3,char);
3246     (void)strcpy(text, dd->pattern);
3247     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3248
3249     /* Set up the pattern descriptor. */
3250     pat.dsc$a_pointer = text;
3251     pat.dsc$w_length = i + e->d_namlen - 1;
3252     pat.dsc$b_dtype = DSC$K_DTYPE_T;
3253     pat.dsc$b_class = DSC$K_CLASS_S;
3254
3255     /* Set up result descriptor. */
3256     res.dsc$a_pointer = buff;
3257     res.dsc$w_length = sizeof buff - 2;
3258     res.dsc$b_dtype = DSC$K_DTYPE_T;
3259     res.dsc$b_class = DSC$K_CLASS_S;
3260
3261     /* Read files, collecting versions. */
3262     for (context = 0, e->vms_verscount = 0;
3263          e->vms_verscount < VERSIZE(e);
3264          e->vms_verscount++) {
3265         tmpsts = lib$find_file(&pat, &res, &context);
3266         if (tmpsts == RMS$_NMF || context == 0) break;
3267         _ckvmssts(tmpsts);
3268         buff[sizeof buff - 1] = '\0';
3269         if ((p = strchr(buff, ';')))
3270             e->vms_versions[e->vms_verscount] = atoi(p + 1);
3271         else
3272             e->vms_versions[e->vms_verscount] = -1;
3273     }
3274
3275     _ckvmssts(lib$find_file_end(&context));
3276     Safefree(text);
3277
3278 }  /* end of collectversions() */
3279
3280 /*
3281  *  Read the next entry from the directory.
3282  */
3283 /*{{{ struct dirent *readdir(DIR *dd)*/
3284 struct dirent *
3285 readdir(DIR *dd)
3286 {
3287     struct dsc$descriptor_s     res;
3288     char *p, buff[sizeof dd->entry.d_name];
3289     unsigned long int tmpsts;
3290
3291     /* Set up result descriptor, and get next file. */
3292     res.dsc$a_pointer = buff;
3293     res.dsc$w_length = sizeof buff - 2;
3294     res.dsc$b_dtype = DSC$K_DTYPE_T;
3295     res.dsc$b_class = DSC$K_CLASS_S;
3296     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3297     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
3298     if (!(tmpsts & 1)) {
3299       set_vaxc_errno(tmpsts);
3300       switch (tmpsts) {
3301         case RMS$_PRV:
3302           set_errno(EACCES); break;
3303         case RMS$_DEV:
3304           set_errno(ENODEV); break;
3305         case RMS$_DIR:
3306           set_errno(ENOTDIR); break;
3307         case RMS$_FNF: case RMS$_DNF:
3308           set_errno(ENOENT); break;
3309         default:
3310           set_errno(EVMSERR);
3311       }
3312       return NULL;
3313     }
3314     dd->count++;
3315     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3316     buff[sizeof buff - 1] = '\0';
3317     for (p = buff; *p; p++) *p = _tolower(*p);
3318     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
3319     *p = '\0';
3320
3321     /* Skip any directory component and just copy the name. */
3322     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3323     else (void)strcpy(dd->entry.d_name, buff);
3324
3325     /* Clobber the version. */
3326     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3327
3328     dd->entry.d_namlen = strlen(dd->entry.d_name);
3329     dd->entry.vms_verscount = 0;
3330     if (dd->vms_wantversions) collectversions(dd);
3331     return &dd->entry;
3332
3333 }  /* end of readdir() */
3334 /*}}}*/
3335
3336 /*
3337  *  Return something that can be used in a seekdir later.
3338  */
3339 /*{{{ long telldir(DIR *dd)*/
3340 long
3341 telldir(DIR *dd)
3342 {
3343     return dd->count;
3344 }
3345 /*}}}*/
3346
3347 /*
3348  *  Return to a spot where we used to be.  Brute force.
3349  */
3350 /*{{{ void seekdir(DIR *dd,long count)*/
3351 void
3352 seekdir(DIR *dd, long count)
3353 {
3354     int vms_wantversions;
3355     dTHX;
3356
3357     /* If we haven't done anything yet... */
3358     if (dd->count == 0)
3359         return;
3360
3361     /* Remember some state, and clear it. */
3362     vms_wantversions = dd->vms_wantversions;
3363     dd->vms_wantversions = 0;
3364     _ckvmssts(lib$find_file_end(&dd->context));
3365     dd->context = 0;
3366
3367     /* The increment is in readdir(). */
3368     for (dd->count = 0; dd->count < count; )
3369         (void)readdir(dd);
3370
3371     dd->vms_wantversions = vms_wantversions;
3372
3373 }  /* end of seekdir() */
3374 /*}}}*/
3375
3376 /* VMS subprocess management
3377  *
3378  * my_vfork() - just a vfork(), after setting a flag to record that
3379  * the current script is trying a Unix-style fork/exec.
3380  *
3381  * vms_do_aexec() and vms_do_exec() are called in response to the
3382  * perl 'exec' function.  If this follows a vfork call, then they
3383  * call out the the regular perl routines in doio.c which do an
3384  * execvp (for those who really want to try this under VMS).
3385  * Otherwise, they do exactly what the perl docs say exec should
3386  * do - terminate the current script and invoke a new command
3387  * (See below for notes on command syntax.)
3388  *
3389  * do_aspawn() and do_spawn() implement the VMS side of the perl
3390  * 'system' function.
3391  *
3392  * Note on command arguments to perl 'exec' and 'system': When handled
3393  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3394  * are concatenated to form a DCL command string.  If the first arg
3395  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3396  * the the command string is handed off to DCL directly.  Otherwise,
3397  * the first token of the command is taken as the filespec of an image
3398  * to run.  The filespec is expanded using a default type of '.EXE' and
3399  * the process defaults for device, directory, etc., and if found, the resultant
3400  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3401  * the command string as parameters.  This is perhaps a bit complicated,
3402  * but I hope it will form a happy medium between what VMS folks expect
3403  * from lib$spawn and what Unix folks expect from exec.
3404  */
3405
3406 static int vfork_called;
3407
3408 /*{{{int my_vfork()*/
3409 int
3410 my_vfork()
3411 {
3412   vfork_called++;
3413   return vfork();
3414 }
3415 /*}}}*/
3416
3417
3418 static void
3419 vms_execfree(pTHX) {
3420   if (PL_Cmd) {
3421     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3422     PL_Cmd = Nullch;
3423   }
3424   if (VMScmd.dsc$a_pointer) {
3425     Safefree(VMScmd.dsc$a_pointer);
3426     VMScmd.dsc$w_length = 0;
3427     VMScmd.dsc$a_pointer = Nullch;
3428   }
3429 }
3430
3431 static char *
3432 setup_argstr(SV *really, SV **mark, SV **sp)
3433 {
3434   dTHX;
3435   char *junk, *tmps = Nullch;
3436   register size_t cmdlen = 0;
3437   size_t rlen;
3438   register SV **idx;
3439   STRLEN n_a;
3440
3441   idx = mark;
3442   if (really) {
3443     tmps = SvPV(really,rlen);
3444     if (*tmps) {
3445       cmdlen += rlen + 1;
3446       idx++;
3447     }
3448   }
3449
3450   for (idx++; idx <= sp; idx++) {
3451     if (*idx) {
3452       junk = SvPVx(*idx,rlen);
3453       cmdlen += rlen ? rlen + 1 : 0;
3454     }
3455   }
3456   New(401,PL_Cmd,cmdlen+1,char);
3457
3458   if (tmps && *tmps) {
3459     strcpy(PL_Cmd,tmps);
3460     mark++;
3461   }
3462   else *PL_Cmd = '\0';
3463   while (++mark <= sp) {
3464     if (*mark) {
3465       char *s = SvPVx(*mark,n_a);
3466       if (!*s) continue;
3467       if (*PL_Cmd) strcat(PL_Cmd," ");
3468       strcat(PL_Cmd,s);
3469     }
3470   }
3471   return PL_Cmd;
3472
3473 }  /* end of setup_argstr() */
3474
3475
3476 static unsigned long int
3477 setup_cmddsc(char *cmd, int check_img)
3478 {
3479   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3480   $DESCRIPTOR(defdsc,".EXE");
3481   $DESCRIPTOR(defdsc2,".");
3482   $DESCRIPTOR(resdsc,resspec);
3483   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3484   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3485   register char *s, *rest, *cp, *wordbreak;
3486   register int isdcl;
3487   dTHX;
3488
3489   if (strlen(cmd) >
3490       (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3491     return LIB$_INVARG;
3492   s = cmd;
3493   while (*s && isspace(*s)) s++;
3494
3495   if (*s == '@' || *s == '$') {
3496     vmsspec[0] = *s;  rest = s + 1;
3497     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3498   }
3499   else { cp = vmsspec; rest = s; }
3500   if (*rest == '.' || *rest == '/') {
3501     char *cp2;
3502     for (cp2 = resspec;
3503          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3504          rest++, cp2++) *cp2 = *rest;
3505     *cp2 = '\0';
3506     if (do_tovmsspec(resspec,cp,0)) {
3507       s = vmsspec;
3508       if (*rest) {
3509         for (cp2 = vmsspec + strlen(vmsspec);
3510              *rest && cp2 - vmsspec < sizeof vmsspec;
3511              rest++, cp2++) *cp2 = *rest;
3512         *cp2 = '\0';
3513       }
3514     }
3515   }
3516   /* Intuit whether verb (first word of cmd) is a DCL command:
3517    *   - if first nonspace char is '@', it's a DCL indirection
3518    * otherwise
3519    *   - if verb contains a filespec separator, it's not a DCL command
3520    *   - if it doesn't, caller tells us whether to default to a DCL
3521    *     command, or to a local image unless told it's DCL (by leading '$')
3522    */
3523   if (*s == '@') isdcl = 1;
3524   else {
3525     register char *filespec = strpbrk(s,":<[.;");
3526     rest = wordbreak = strpbrk(s," \"\t/");
3527     if (!wordbreak) wordbreak = s + strlen(s);
3528     if (*s == '$') check_img = 0;
3529     if (filespec && (filespec < wordbreak)) isdcl = 0;
3530     else isdcl = !check_img;
3531   }
3532
3533   if (!isdcl) {
3534     imgdsc.dsc$a_pointer = s;
3535     imgdsc.dsc$w_length = wordbreak - s;
3536     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3537     if (!(retsts&1)) {
3538         _ckvmssts(lib$find_file_end(&cxt));
3539         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3540     if (!(retsts & 1) && *s == '$') {
3541           _ckvmssts(lib$find_file_end(&cxt));
3542       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3543       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3544           if (!(retsts&1)) {
3545       _ckvmssts(lib$find_file_end(&cxt));
3546             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3547           }
3548     }
3549     }
3550     _ckvmssts(lib$find_file_end(&cxt));
3551
3552     if (retsts & 1) {
3553       FILE *fp;
3554       s = resspec;
3555       while (*s && !isspace(*s)) s++;
3556       *s = '\0';
3557
3558       /* check that it's really not DCL with no file extension */
3559       fp = fopen(resspec,"r","ctx=bin,shr=get");
3560       if (fp) {
3561         char b[4] = {0,0,0,0};
3562         read(fileno(fp),b,4);
3563         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3564         fclose(fp);
3565       }
3566       if (check_img && isdcl) return RMS$_FNF;
3567
3568       if (cando_by_name(S_IXUSR,0,resspec)) {
3569         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3570         if (!isdcl) {
3571         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3572         } else {
3573             strcpy(VMScmd.dsc$a_pointer,"@");
3574         }
3575         strcat(VMScmd.dsc$a_pointer,resspec);
3576         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3577         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3578         return retsts;
3579       }
3580       else retsts = RMS$_PRV;
3581     }
3582   }
3583   /* It's either a DCL command or we couldn't find a suitable image */
3584   VMScmd.dsc$w_length = strlen(cmd);
3585   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3586   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3587   if (!(retsts & 1)) {
3588     /* just hand off status values likely to be due to user error */
3589     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3590         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3591        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3592     else { _ckvmssts(retsts); }
3593   }
3594
3595   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3596
3597 }  /* end of setup_cmddsc() */
3598
3599
3600 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3601 bool
3602 vms_do_aexec(SV *really,SV **mark,SV **sp)
3603 {
3604   dTHX;
3605   if (sp > mark) {
3606     if (vfork_called) {           /* this follows a vfork - act Unixish */
3607       vfork_called--;
3608       if (vfork_called < 0) {
3609         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3610         vfork_called = 0;
3611       }
3612       else return do_aexec(really,mark,sp);
3613     }
3614                                            /* no vfork - act VMSish */
3615     return vms_do_exec(setup_argstr(really,mark,sp));
3616
3617   }
3618
3619   return FALSE;
3620 }  /* end of vms_do_aexec() */
3621 /*}}}*/
3622
3623 /* {{{bool vms_do_exec(char *cmd) */
3624 bool
3625 vms_do_exec(char *cmd)
3626 {
3627
3628   dTHX;
3629   if (vfork_called) {             /* this follows a vfork - act Unixish */
3630     vfork_called--;
3631     if (vfork_called < 0) {
3632       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3633       vfork_called = 0;
3634     }
3635     else return do_exec(cmd);
3636   }
3637
3638   {                               /* no vfork - act VMSish */
3639     unsigned long int retsts;
3640
3641     TAINT_ENV();
3642     TAINT_PROPER("exec");
3643     if ((retsts = setup_cmddsc(cmd,1)) & 1)
3644       retsts = lib$do_command(&VMScmd);
3645
3646     switch (retsts) {
3647       case RMS$_FNF: case RMS$_DNF:
3648         set_errno(ENOENT); break;
3649       case RMS$_DIR:
3650         set_errno(ENOTDIR); break;
3651       case RMS$_DEV:
3652         set_errno(ENODEV); break;
3653       case RMS$_PRV:
3654         set_errno(EACCES); break;
3655       case RMS$_SYN:
3656         set_errno(EINVAL); break;
3657       case CLI$_BUFOVF:
3658         set_errno(E2BIG); break;
3659       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3660         _ckvmssts(retsts); /* fall through */
3661       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3662         set_errno(EVMSERR);
3663     }
3664     set_vaxc_errno(retsts);
3665     if (ckWARN(WARN_EXEC)) {
3666       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3667              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3668     }
3669     vms_execfree(aTHX);
3670   }
3671
3672   return FALSE;
3673
3674 }  /* end of vms_do_exec() */
3675 /*}}}*/
3676
3677 unsigned long int do_spawn(char *);
3678
3679 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3680 unsigned long int
3681 do_aspawn(void *really,void **mark,void **sp)
3682 {
3683   dTHX;
3684   if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3685
3686   return SS$_ABORT;
3687 }  /* end of do_aspawn() */
3688 /*}}}*/
3689
3690 /* {{{unsigned long int do_spawn(char *cmd) */
3691 unsigned long int
3692 do_spawn(char *cmd)
3693 {
3694   unsigned long int sts, substs, hadcmd = 1;
3695   dTHX;
3696
3697   TAINT_ENV();
3698   TAINT_PROPER("spawn");
3699   if (!cmd || !*cmd) {
3700     hadcmd = 0;
3701     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3702   }
3703   else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3704     sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3705   }
3706
3707   if (!(sts & 1)) {
3708     switch (sts) {
3709       case RMS$_FNF:  case RMS$_DNF:
3710         set_errno(ENOENT); break;
3711       case RMS$_DIR:
3712         set_errno(ENOTDIR); break;
3713       case RMS$_DEV:
3714         set_errno(ENODEV); break;
3715       case RMS$_PRV:
3716         set_errno(EACCES); break;
3717       case RMS$_SYN:
3718         set_errno(EINVAL); break;
3719       case CLI$_BUFOVF:
3720         set_errno(E2BIG); break;
3721       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3722         _ckvmssts(sts); /* fall through */
3723       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3724         set_errno(EVMSERR);
3725     }
3726     set_vaxc_errno(sts);
3727     if (ckWARN(WARN_EXEC)) {
3728       Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3729              hadcmd ? VMScmd.dsc$w_length :  0,
3730              hadcmd ? VMScmd.dsc$a_pointer : "",
3731              Strerror(errno));
3732     }
3733   }
3734   vms_execfree(aTHX);
3735   return substs;
3736
3737 }  /* end of do_spawn() */
3738 /*}}}*/
3739
3740 /*
3741  * A simple fwrite replacement which outputs itmsz*nitm chars without
3742  * introducing record boundaries every itmsz chars.
3743  */
3744 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3745 int
3746 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3747 {
3748   register char *cp, *end;
3749
3750   end = (char *)src + itmsz * nitm;
3751
3752   while ((char *)src <= end) {
3753     for (cp = src; cp <= end; cp++) if (!*cp) break;
3754     if (fputs(src,dest) == EOF) return EOF;
3755     if (cp < end)
3756       if (fputc('\0',dest) == EOF) return EOF;
3757     src = cp + 1;
3758   }
3759
3760   return 1;
3761
3762 }  /* end of my_fwrite() */
3763 /*}}}*/
3764
3765 /*{{{ int my_flush(FILE *fp)*/
3766 int
3767 my_flush(FILE *fp)
3768 {
3769     int res;
3770     if ((res = fflush(fp)) == 0 && fp) {
3771 #ifdef VMS_DO_SOCKETS
3772         Stat_t s;
3773         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3774 #endif
3775             res = fsync(fileno(fp));
3776     }
3777     return res;
3778 }
3779 /*}}}*/
3780
3781 /*
3782  * Here are replacements for the following Unix routines in the VMS environment:
3783  *      getpwuid    Get information for a particular UIC or UID
3784  *      getpwnam    Get information for a named user
3785  *      getpwent    Get information for each user in the rights database
3786  *      setpwent    Reset search to the start of the rights database
3787  *      endpwent    Finish searching for users in the rights database
3788  *
3789  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3790  * (defined in pwd.h), which contains the following fields:-
3791  *      struct passwd {
3792  *              char        *pw_name;    Username (in lower case)
3793  *              char        *pw_passwd;  Hashed password
3794  *              unsigned int pw_uid;     UIC
3795  *              unsigned int pw_gid;     UIC group  number
3796  *              char        *pw_unixdir; Default device/directory (VMS-style)
3797  *              char        *pw_gecos;   Owner name
3798  *              char        *pw_dir;     Default device/directory (Unix-style)
3799  *              char        *pw_shell;   Default CLI name (eg. DCL)
3800  *      };
3801  * If the specified user does not exist, getpwuid and getpwnam return NULL.
3802  *
3803  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3804  * not the UIC member number (eg. what's returned by getuid()),
3805  * getpwuid() can accept either as input (if uid is specified, the caller's
3806  * UIC group is used), though it won't recognise gid=0.
3807  *
3808  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3809  * information about other users in your group or in other groups, respectively.
3810  * If the required privilege is not available, then these routines fill only
3811  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3812  * string).
3813  *
3814  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3815  */
3816
3817 /* sizes of various UAF record fields */
3818 #define UAI$S_USERNAME 12
3819 #define UAI$S_IDENT    31
3820 #define UAI$S_OWNER    31
3821 #define UAI$S_DEFDEV   31
3822 #define UAI$S_DEFDIR   63
3823 #define UAI$S_DEFCLI   31
3824 #define UAI$S_PWD       8
3825
3826 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
3827                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3828                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
3829
3830 static char __empty[]= "";
3831 static struct passwd __passwd_empty=
3832     {(char *) __empty, (char *) __empty, 0, 0,
3833      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3834 static int contxt= 0;
3835 static struct passwd __pwdcache;
3836 static char __pw_namecache[UAI$S_IDENT+1];
3837
3838 /*
3839  * This routine does most of the work extracting the user information.
3840  */
3841 static int fillpasswd (const char *name, struct passwd *pwd)
3842 {
3843     dTHX;
3844     static struct {
3845         unsigned char length;
3846         char pw_gecos[UAI$S_OWNER+1];
3847     } owner;
3848     static union uicdef uic;
3849     static struct {
3850         unsigned char length;
3851         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3852     } defdev;
3853     static struct {
3854         unsigned char length;
3855         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3856     } defdir;
3857     static struct {
3858         unsigned char length;
3859         char pw_shell[UAI$S_DEFCLI+1];
3860     } defcli;
3861     static char pw_passwd[UAI$S_PWD+1];
3862
3863     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3864     struct dsc$descriptor_s name_desc;
3865     unsigned long int sts;
3866
3867     static struct itmlst_3 itmlst[]= {
3868         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
3869         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
3870         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
3871         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
3872         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
3873         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
3874         {0,                0,           NULL,    NULL}};
3875
3876     name_desc.dsc$w_length=  strlen(name);
3877     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3878     name_desc.dsc$b_class=   DSC$K_CLASS_S;
3879     name_desc.dsc$a_pointer= (char *) name;
3880
3881 /*  Note that sys$getuai returns many fields as counted strings. */
3882     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3883     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3884       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3885     }
3886     else { _ckvmssts(sts); }
3887     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
3888
3889     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
3890     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3891     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3892     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3893     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3894     owner.pw_gecos[lowner]=            '\0';
3895     defdev.pw_dir[ldefdev+ldefdir]= '\0';
3896     defcli.pw_shell[ldefcli]=          '\0';
3897     if (valid_uic(uic)) {
3898         pwd->pw_uid= uic.uic$l_uic;
3899         pwd->pw_gid= uic.uic$v_group;
3900     }
3901     else
3902       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3903     pwd->pw_passwd=  pw_passwd;
3904     pwd->pw_gecos=   owner.pw_gecos;
3905     pwd->pw_dir=     defdev.pw_dir;
3906     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3907     pwd->pw_shell=   defcli.pw_shell;
3908     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3909         int ldir;
3910         ldir= strlen(pwd->pw_unixdir) - 1;
3911         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3912     }
3913     else
3914         strcpy(pwd->pw_unixdir, pwd->pw_dir);
3915     __mystrtolower(pwd->pw_unixdir);
3916     return 1;
3917 }
3918
3919 /*
3920  * Get information for a named user.
3921 */
3922 /*{{{struct passwd *getpwnam(char *name)*/
3923 struct passwd *my_getpwnam(char *name)
3924 {
3925     struct dsc$descriptor_s name_desc;
3926     union uicdef uic;
3927     unsigned long int status, sts;
3928     dTHX;
3929
3930     __pwdcache = __passwd_empty;
3931     if (!fillpasswd(name, &__pwdcache)) {
3932       /* We still may be able to determine pw_uid and pw_gid */
3933       name_desc.dsc$w_length=  strlen(name);
3934       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3935       name_desc.dsc$b_class=   DSC$K_CLASS_S;
3936       name_desc.dsc$a_pointer= (char *) name;
3937       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3938         __pwdcache.pw_uid= uic.uic$l_uic;
3939         __pwdcache.pw_gid= uic.uic$v_group;
3940       }
3941       else {
3942         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3943           set_vaxc_errno(sts);
3944           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3945           return NULL;
3946         }
3947         else { _ckvmssts(sts); }
3948       }
3949     }
3950     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3951     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3952     __pwdcache.pw_name= __pw_namecache;
3953     return &__pwdcache;
3954 }  /* end of my_getpwnam() */
3955 /*}}}*/
3956
3957 /*
3958  * Get information for a particular UIC or UID.
3959  * Called by my_getpwent with uid=-1 to list all users.
3960 */
3961 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3962 struct passwd *my_getpwuid(Uid_t uid)
3963 {
3964     const $DESCRIPTOR(name_desc,__pw_namecache);
3965     unsigned short lname;
3966     union uicdef uic;
3967     unsigned long int status;
3968     dTHX;
3969
3970     if (uid == (unsigned int) -1) {
3971       do {
3972         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3973         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3974           set_vaxc_errno(status);
3975           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3976           my_endpwent();
3977           return NULL;
3978         }
3979         else { _ckvmssts(status); }
3980       } while (!valid_uic (uic));
3981     }
3982     else {
3983       uic.uic$l_uic= uid;
3984       if (!uic.uic$v_group)
3985         uic.uic$v_group= PerlProc_getgid();
3986       if (valid_uic(uic))
3987         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3988       else status = SS$_IVIDENT;
3989       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3990           status == RMS$_PRV) {
3991         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3992         return NULL;
3993       }
3994       else { _ckvmssts(status); }
3995     }
3996     __pw_namecache[lname]= '\0';
3997     __mystrtolower(__pw_namecache);
3998
3999     __pwdcache = __passwd_empty;
4000     __pwdcache.pw_name = __pw_namecache;
4001
4002 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
4003     The identifier's value is usually the UIC, but it doesn't have to be,
4004     so if we can, we let fillpasswd update this. */
4005     __pwdcache.pw_uid =  uic.uic$l_uic;
4006     __pwdcache.pw_gid =  uic.uic$v_group;
4007
4008     fillpasswd(__pw_namecache, &__pwdcache);
4009     return &__pwdcache;
4010
4011 }  /* end of my_getpwuid() */
4012 /*}}}*/
4013
4014 /*
4015  * Get information for next user.
4016 */
4017 /*{{{struct passwd *my_getpwent()*/
4018 struct passwd *my_getpwent()
4019 {
4020     return (my_getpwuid((unsigned int) -1));
4021 }
4022 /*}}}*/
4023
4024 /*
4025  * Finish searching rights database for users.
4026 */
4027 /*{{{void my_endpwent()*/
4028 void my_endpwent()
4029 {
4030     dTHX;
4031     if (contxt) {
4032       _ckvmssts(sys$finish_rdb(&contxt));
4033       contxt= 0;
4034     }
4035 }
4036 /*}}}*/
4037
4038 #ifdef HOMEGROWN_POSIX_SIGNALS
4039   /* Signal handling routines, pulled into the core from POSIX.xs.
4040    *
4041    * We need these for threads, so they've been rolled into the core,
4042    * rather than left in POSIX.xs.
4043    *
4044    * (DRS, Oct 23, 1997)
4045    */
4046
4047   /* sigset_t is atomic under VMS, so these routines are easy */
4048 /*{{{int my_sigemptyset(sigset_t *) */
4049 int my_sigemptyset(sigset_t *set) {
4050     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4051     *set = 0; return 0;
4052 }
4053 /*}}}*/
4054
4055
4056 /*{{{int my_sigfillset(sigset_t *)*/
4057 int my_sigfillset(sigset_t *set) {
4058     int i;
4059     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4060     for (i = 0; i < NSIG; i++) *set |= (1 << i);
4061     return 0;
4062 }
4063 /*}}}*/
4064
4065
4066 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4067 int my_sigaddset(sigset_t *set, int sig) {
4068     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4069     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4070     *set |= (1 << (sig - 1));
4071     return 0;
4072 }
4073 /*}}}*/
4074
4075
4076 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4077 int my_sigdelset(sigset_t *set, int sig) {
4078     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4079     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4080     *set &= ~(1 << (sig - 1));
4081     return 0;
4082 }
4083 /*}}}*/
4084
4085
4086 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4087 int my_sigismember(sigset_t *set, int sig) {
4088     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4089     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4090     *set & (1 << (sig - 1));
4091 }
4092 /*}}}*/
4093
4094
4095 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4096 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4097     sigset_t tempmask;
4098
4099     /* If set and oset are both null, then things are badly wrong. Bail out. */
4100     if ((oset == NULL) && (set == NULL)) {
4101       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4102       return -1;
4103     }
4104
4105     /* If set's null, then we're just handling a fetch. */
4106     if (set == NULL) {
4107         tempmask = sigblock(0);
4108     }
4109     else {
4110       switch (how) {
4111       case SIG_SETMASK:
4112         tempmask = sigsetmask(*set);
4113         break;
4114       case SIG_BLOCK:
4115         tempmask = sigblock(*set);
4116         break;
4117       case SIG_UNBLOCK:
4118         tempmask = sigblock(0);
4119         sigsetmask(*oset & ~tempmask);
4120         break;
4121       default:
4122         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4123         return -1;
4124       }
4125     }
4126
4127     /* Did they pass us an oset? If so, stick our holding mask into it */
4128     if (oset)
4129       *oset = tempmask;
4130
4131     return 0;
4132 }
4133 /*}}}*/
4134 #endif  /* HOMEGROWN_POSIX_SIGNALS */
4135
4136
4137 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4138  * my_utime(), and flex_stat(), all of which operate on UTC unless
4139  * VMSISH_TIMES is true.
4140  */
4141 /* method used to handle UTC conversions:
4142  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
4143  */
4144 static int gmtime_emulation_type;
4145 /* number of secs to add to UTC POSIX-style time to get local time */
4146 static long int utc_offset_secs;
4147
4148 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4149  * in vmsish.h.  #undef them here so we can call the CRTL routines
4150  * directly.
4151  */
4152 #undef gmtime
4153 #undef localtime
4154 #undef time
4155
4156 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4157 #  define RTL_USES_UTC 1
4158 #endif
4159
4160 /*
4161  * DEC C previous to 6.0 corrupts the behavior of the /prefix
4162  * qualifier with the extern prefix pragma.  This provisional
4163  * hack circumvents this prefix pragma problem in previous
4164  * precompilers.
4165  */
4166 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4167 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4168 #    pragma __extern_prefix save
4169 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
4170 #    define gmtime decc$__utctz_gmtime
4171 #    define localtime decc$__utctz_localtime
4172 #    define time decc$__utc_time
4173 #    pragma __extern_prefix restore
4174
4175      struct tm *gmtime(), *localtime();
4176
4177 #  endif
4178 #endif
4179
4180
4181 static time_t toutc_dst(time_t loc) {
4182   struct tm *rsltmp;
4183
4184   if ((rsltmp = localtime(&loc)) == NULL) return -1;
4185   loc -= utc_offset_secs;
4186   if (rsltmp->tm_isdst) loc -= 3600;
4187   return loc;
4188 }
4189 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4190        ((gmtime_emulation_type || my_time(NULL)), \
4191        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4192        ((secs) - utc_offset_secs))))
4193
4194 static time_t toloc_dst(time_t utc) {
4195   struct tm *rsltmp;
4196
4197   utc += utc_offset_secs;
4198   if ((rsltmp = localtime(&utc)) == NULL) return -1;
4199   if (rsltmp->tm_isdst) utc += 3600;
4200   return utc;
4201 }
4202 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4203        ((gmtime_emulation_type || my_time(NULL)), \
4204        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4205        ((secs) + utc_offset_secs))))
4206
4207
4208 /* my_time(), my_localtime(), my_gmtime()
4209  * By default traffic in UTC time values, using CRTL gmtime() or
4210  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4211  * Note: We need to use these functions even when the CRTL has working
4212  * UTC support, since they also handle C<use vmsish qw(times);>
4213  *
4214  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
4215  * Modified by Charles Bailey <bailey@newman.upenn.edu>
4216  */
4217
4218 /*{{{time_t my_time(time_t *timep)*/
4219 time_t my_time(time_t *timep)
4220 {
4221   dTHX;
4222   time_t when;
4223   struct tm *tm_p;
4224
4225   if (gmtime_emulation_type == 0) {
4226     int dstnow;
4227     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
4228                               /* results of calls to gmtime() and localtime() */
4229                               /* for same &base */
4230
4231     gmtime_emulation_type++;
4232     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4233       char off[LNM$C_NAMLENGTH+1];;
4234
4235       gmtime_emulation_type++;
4236       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4237         gmtime_emulation_type++;
4238         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4239       }
4240       else { utc_offset_secs = atol(off); }
4241     }
4242     else { /* We've got a working gmtime() */
4243       struct tm gmt, local;
4244
4245       gmt = *tm_p;
4246       tm_p = localtime(&base);
4247       local = *tm_p;
4248       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
4249       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4250       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
4251       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
4252     }
4253   }
4254
4255   when = time(NULL);
4256 # ifdef VMSISH_TIME
4257 # ifdef RTL_USES_UTC
4258   if (VMSISH_TIME) when = _toloc(when);
4259 # else
4260   if (!VMSISH_TIME) when = _toutc(when);
4261 # endif
4262 # endif
4263   if (timep != NULL) *timep = when;
4264   return when;
4265
4266 }  /* end of my_time() */
4267 /*}}}*/
4268
4269
4270 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4271 struct tm *
4272 my_gmtime(const time_t *timep)
4273 {
4274   dTHX;
4275   char *p;
4276   time_t when;
4277   struct tm *rsltmp;
4278
4279   if (timep == NULL) {
4280     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4281     return NULL;
4282   }
4283   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4284
4285   when = *timep;
4286 # ifdef VMSISH_TIME
4287   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4288 #  endif
4289 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
4290   return gmtime(&when);
4291 # else
4292   /* CRTL localtime() wants local time as input, so does no tz correction */
4293   rsltmp = localtime(&when);
4294   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
4295   return rsltmp;
4296 #endif
4297 }  /* end of my_gmtime() */
4298 /*}}}*/
4299
4300
4301 /*{{{struct tm *my_localtime(const time_t *timep)*/
4302 struct tm *
4303 my_localtime(const time_t *timep)
4304 {
4305   dTHX;
4306   time_t when;
4307   struct tm *rsltmp;
4308
4309   if (timep == NULL) {
4310     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4311     return NULL;
4312   }
4313   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4314   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4315
4316   when = *timep;
4317 # ifdef RTL_USES_UTC
4318 # ifdef VMSISH_TIME
4319   if (VMSISH_TIME) when = _toutc(when);
4320 # endif
4321   /* CRTL localtime() wants UTC as input, does tz correction itself */
4322   return localtime(&when);
4323 # else
4324 # ifdef VMSISH_TIME
4325   if (!VMSISH_TIME) when = _toloc(when);   /*  Input was UTC */
4326 # endif
4327 # endif
4328   /* CRTL localtime() wants local time as input, so does no tz correction */
4329   rsltmp = localtime(&when);
4330   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4331   return rsltmp;
4332
4333 } /*  end of my_localtime() */
4334 /*}}}*/
4335
4336 /* Reset definitions for later calls */
4337 #define gmtime(t)    my_gmtime(t)
4338 #define localtime(t) my_localtime(t)
4339 #define time(t)      my_time(t)
4340
4341
4342 /* my_utime - update modification time of a file
4343  * calling sequence is identical to POSIX utime(), but under
4344  * VMS only the modification time is changed; ODS-2 does not
4345  * maintain access times.  Restrictions differ from the POSIX
4346  * definition in that the time can be changed as long as the
4347  * caller has permission to execute the necessary IO$_MODIFY $QIO;
4348  * no separate checks are made to insure that the caller is the
4349  * owner of the file or has special privs enabled.
4350  * Code here is based on Joe Meadows' FILE utility.
4351  */
4352
4353 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4354  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
4355  * in 100 ns intervals.
4356  */
4357 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4358
4359 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4360 int my_utime(char *file, struct utimbuf *utimes)
4361 {
4362   dTHX;
4363   register int i;
4364   long int bintime[2], len = 2, lowbit, unixtime,
4365            secscale = 10000000; /* seconds --> 100 ns intervals */
4366   unsigned long int chan, iosb[2], retsts;
4367   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4368   struct FAB myfab = cc$rms_fab;
4369   struct NAM mynam = cc$rms_nam;
4370 #if defined (__DECC) && defined (__VAX)
4371   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4372    * at least through VMS V6.1, which causes a type-conversion warning.
4373    */
4374 #  pragma message save
4375 #  pragma message disable cvtdiftypes
4376 #endif
4377   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4378   struct fibdef myfib;
4379 #if defined (__DECC) && defined (__VAX)
4380   /* This should be right after the declaration of myatr, but due
4381    * to a bug in VAX DEC C, this takes effect a statement early.
4382    */
4383 #  pragma message restore
4384 #endif
4385   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4386                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4387                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4388
4389   if (file == NULL || *file == '\0') {
4390     set_errno(ENOENT);
4391     set_vaxc_errno(LIB$_INVARG);
4392     return -1;
4393   }
4394   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4395
4396   if (utimes != NULL) {
4397     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
4398      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4399      * Since time_t is unsigned long int, and lib$emul takes a signed long int
4400      * as input, we force the sign bit to be clear by shifting unixtime right
4401      * one bit, then multiplying by an extra factor of 2 in lib$emul().
4402      */
4403     lowbit = (utimes->modtime & 1) ? secscale : 0;
4404     unixtime = (long int) utimes->modtime;
4405 #   ifdef VMSISH_TIME
4406     /* If input was UTC; convert to local for sys svc */
4407     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4408 #   endif
4409     unixtime >>= 1;  secscale <<= 1;
4410     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4411     if (!(retsts & 1)) {
4412       set_errno(EVMSERR);
4413       set_vaxc_errno(retsts);
4414       return -1;
4415     }
4416     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4417     if (!(retsts & 1)) {
4418       set_errno(EVMSERR);
4419       set_vaxc_errno(retsts);
4420       return -1;
4421     }
4422   }
4423   else {
4424     /* Just get the current time in VMS format directly */
4425     retsts = sys$gettim(bintime);
4426     if (!(retsts & 1)) {
4427       set_errno(EVMSERR);
4428       set_vaxc_errno(retsts);
4429       return -1;
4430     }
4431   }
4432
4433   myfab.fab$l_fna = vmsspec;
4434   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4435   myfab.fab$l_nam = &mynam;
4436   mynam.nam$l_esa = esa;
4437   mynam.nam$b_ess = (unsigned char) sizeof esa;
4438   mynam.nam$l_rsa = rsa;
4439   mynam.nam$b_rss = (unsigned char) sizeof rsa;
4440
4441   /* Look for the file to be affected, letting RMS parse the file
4442    * specification for us as well.  I have set errno using only
4443    * values documented in the utime() man page for VMS POSIX.
4444    */
4445   retsts = sys$parse(&myfab,0,0);
4446   if (!(retsts & 1)) {
4447     set_vaxc_errno(retsts);
4448     if      (retsts == RMS$_PRV) set_errno(EACCES);
4449     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4450     else                         set_errno(EVMSERR);
4451     return -1;
4452   }
4453   retsts = sys$search(&myfab,0,0);
4454   if (!(retsts & 1)) {
4455     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4456     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4457     set_vaxc_errno(retsts);
4458     if      (retsts == RMS$_PRV) set_errno(EACCES);
4459     else if (retsts == RMS$_FNF) set_errno(ENOENT);
4460     else                         set_errno(EVMSERR);
4461     return -1;
4462   }
4463
4464   devdsc.dsc$w_length = mynam.nam$b_dev;
4465   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4466
4467   retsts = sys$assign(&devdsc,&chan,0,0);
4468   if (!(retsts & 1)) {
4469     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4470     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4471     set_vaxc_errno(retsts);
4472     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
4473     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
4474     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
4475     else                               set_errno(EVMSERR);
4476     return -1;
4477   }
4478
4479   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4480   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4481
4482   memset((void *) &myfib, 0, sizeof myfib);
4483 #ifdef __DECC
4484   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4485   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4486   /* This prevents the revision time of the file being reset to the current
4487    * time as a result of our IO$_MODIFY $QIO. */
4488   myfib.fib$l_acctl = FIB$M_NORECORD;
4489 #else
4490   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4491   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4492   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4493 #endif
4494   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4495   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4496   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4497   _ckvmssts(sys$dassgn(chan));
4498   if (retsts & 1) retsts = iosb[0];
4499   if (!(retsts & 1)) {
4500     set_vaxc_errno(retsts);
4501     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4502     else                      set_errno(EVMSERR);
4503     return -1;
4504   }
4505
4506   return 0;
4507 }  /* end of my_utime() */
4508 /*}}}*/
4509
4510 /*
4511  * flex_stat, flex_fstat
4512  * basic stat, but gets it right when asked to stat
4513  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4514  */
4515
4516 /* encode_dev packs a VMS device name string into an integer to allow
4517  * simple comparisons. This can be used, for example, to check whether two
4518  * files are located on the same device, by comparing their encoded device
4519  * names. Even a string comparison would not do, because stat() reuses the
4520  * device name buffer for each call; so without encode_dev, it would be
4521  * necessary to save the buffer and use strcmp (this would mean a number of
4522  * changes to the standard Perl code, to say nothing of what a Perl script
4523  * would have to do.
4524  *
4525  * The device lock id, if it exists, should be unique (unless perhaps compared
4526  * with lock ids transferred from other nodes). We have a lock id if the disk is
4527  * mounted cluster-wide, which is when we tend to get long (host-qualified)
4528  * device names. Thus we use the lock id in preference, and only if that isn't
4529  * available, do we try to pack the device name into an integer (flagged by
4530  * the sign bit (LOCKID_MASK) being set).
4531  *
4532  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4533  * name and its encoded form, but it seems very unlikely that we will find
4534  * two files on different disks that share the same encoded device names,
4535  * and even more remote that they will share the same file id (if the test
4536  * is to check for the same file).
4537  *
4538  * A better method might be to use sys$device_scan on the first call, and to
4539  * search for the device, returning an index into the cached array.
4540  * The number returned would be more intelligable.
4541  * This is probably not worth it, and anyway would take quite a bit longer
4542  * on the first call.
4543  */
4544 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
4545 static mydev_t encode_dev (const char *dev)
4546 {
4547   int i;
4548   unsigned long int f;
4549   mydev_t enc;
4550   char c;
4551   const char *q;
4552   dTHX;
4553
4554   if (!dev || !dev[0]) return 0;
4555
4556 #if LOCKID_MASK
4557   {
4558     struct dsc$descriptor_s dev_desc;
4559     unsigned long int status, lockid, item = DVI$_LOCKID;
4560
4561     /* For cluster-mounted disks, the disk lock identifier is unique, so we
4562        can try that first. */
4563     dev_desc.dsc$w_length =  strlen (dev);
4564     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
4565     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
4566     dev_desc.dsc$a_pointer = (char *) dev;
4567     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4568     if (lockid) return (lockid & ~LOCKID_MASK);
4569   }
4570 #endif
4571
4572   /* Otherwise we try to encode the device name */
4573   enc = 0;
4574   f = 1;
4575   i = 0;
4576   for (q = dev + strlen(dev); q--; q >= dev) {
4577     if (isdigit (*q))
4578       c= (*q) - '0';
4579     else if (isalpha (toupper (*q)))
4580       c= toupper (*q) - 'A' + (char)10;
4581     else
4582       continue; /* Skip '$'s */
4583     i++;
4584     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
4585     if (i>1) f *= 36;
4586     enc += f * (unsigned long int) c;
4587   }
4588   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
4589
4590 }  /* end of encode_dev() */
4591
4592 static char namecache[NAM$C_MAXRSS+1];
4593
4594 static int
4595 is_null_device(name)
4596     const char *name;
4597 {
4598     dTHX;
4599     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4600        The underscore prefix, controller letter, and unit number are
4601        independently optional; for our purposes, the colon punctuation
4602        is not.  The colon can be trailed by optional directory and/or
4603        filename, but two consecutive colons indicates a nodename rather
4604        than a device.  [pr]  */
4605   if (*name == '_') ++name;
4606   if (tolower(*name++) != 'n') return 0;
4607   if (tolower(*name++) != 'l') return 0;
4608   if (tolower(*name) == 'a') ++name;
4609   if (*name == '0') ++name;
4610   return (*name++ == ':') && (*name != ':');
4611 }
4612
4613 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
4614 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4615  * subset of the applicable information.
4616  */
4617 bool
4618 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4619 {
4620   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4621   else {
4622     char fname[NAM$C_MAXRSS+1];
4623     unsigned long int retsts;
4624     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4625                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4626
4627     /* If the struct mystat is stale, we're OOL; stat() overwrites the
4628        device name on successive calls */
4629     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4630     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4631     namdsc.dsc$a_pointer = fname;
4632     namdsc.dsc$w_length = sizeof fname - 1;
4633
4634     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4635                              &namdsc,&namdsc.dsc$w_length,0,0);
4636     if (retsts & 1) {
4637       fname[namdsc.dsc$w_length] = '\0';
4638       return cando_by_name(bit,effective,fname);
4639     }
4640     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4641       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4642       return FALSE;
4643     }
4644     _ckvmssts(retsts);
4645     return FALSE;  /* Should never get to here */
4646   }
4647 }  /* end of cando() */
4648 /*}}}*/
4649
4650
4651 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4652 I32
4653 cando_by_name(I32 bit, Uid_t effective, char *fname)
4654 {
4655   static char usrname[L_cuserid];
4656   static struct dsc$descriptor_s usrdsc =
4657          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4658   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4659   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4660   unsigned short int retlen;
4661   dTHX;
4662   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4663   union prvdef curprv;
4664   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4665          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4666   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4667          {0,0,0,0}};
4668
4669   if (!fname || !*fname) return FALSE;
4670   /* Make sure we expand logical names, since sys$check_access doesn't */
4671   if (!strpbrk(fname,"/]>:")) {
4672     strcpy(fileified,fname);
4673     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4674     fname = fileified;
4675   }
4676   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4677   retlen = namdsc.dsc$w_length = strlen(vmsname);
4678   namdsc.dsc$a_pointer = vmsname;
4679   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4680       vmsname[retlen-1] == ':') {
4681     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4682     namdsc.dsc$w_length = strlen(fileified);
4683     namdsc.dsc$a_pointer = fileified;
4684   }
4685
4686   if (!usrdsc.dsc$w_length) {
4687     cuserid(usrname);
4688     usrdsc.dsc$w_length = strlen(usrname);
4689   }
4690
4691   switch (bit) {
4692     case S_IXUSR: case S_IXGRP: case S_IXOTH:
4693       access = ARM$M_EXECUTE; break;
4694     case S_IRUSR: case S_IRGRP: case S_IROTH:
4695       access = ARM$M_READ; break;
4696     case S_IWUSR: case S_IWGRP: case S_IWOTH:
4697       access = ARM$M_WRITE; break;
4698     case S_IDUSR: case S_IDGRP: case S_IDOTH:
4699       access = ARM$M_DELETE; break;
4700     default:
4701       return FALSE;
4702   }
4703
4704   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4705   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
4706       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4707       retsts == RMS$_DIR        || retsts == RMS$_DEV) {
4708     set_vaxc_errno(retsts);
4709     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4710     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4711     else set_errno(ENOENT);
4712     return FALSE;
4713   }
4714   if (retsts == SS$_NORMAL) {
4715     if (!privused) return TRUE;
4716     /* We can get access, but only by using privs.  Do we have the
4717        necessary privs currently enabled? */
4718     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4719     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
4720     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
4721                                       !curprv.prv$v_bypass)  return FALSE;
4722     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
4723          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
4724     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4725     return TRUE;
4726   }
4727   if (retsts == SS$_ACCONFLICT) {
4728     return TRUE;
4729   }
4730
4731 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 &&  defined(__DECC_VER) && __DECC_VER == 6009001
4732   /* XXX Hideous kluge to accomodate error in specific version of RTL;
4733      we hope it'll be buried soon */
4734   if (retsts == 114762) return TRUE;
4735 #endif
4736   _ckvmssts(retsts);
4737
4738   return FALSE;  /* Should never get here */
4739
4740 }  /* end of cando_by_name() */
4741 /*}}}*/
4742
4743
4744 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4745 int
4746 flex_fstat(int fd, Stat_t *statbufp)
4747 {
4748   dTHX;
4749   if (!fstat(fd,(stat_t *) statbufp)) {
4750     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4751     statbufp->st_dev = encode_dev(statbufp->st_devnam);
4752 #   ifdef RTL_USES_UTC
4753 #   ifdef VMSISH_TIME
4754     if (VMSISH_TIME) {
4755       statbufp->st_mtime = _toloc(statbufp->st_mtime);
4756       statbufp->st_atime = _toloc(statbufp->st_atime);
4757       statbufp->st_ctime = _toloc(statbufp->st_ctime);
4758     }
4759 #   endif
4760 #   else
4761 #   ifdef VMSISH_TIME
4762     if (!VMSISH_TIME) { /* Return UTC instead of local time */
4763 #   else
4764     if (1) {
4765 #   endif
4766       statbufp->st_mtime = _toutc(statbufp->st_mtime);
4767       statbufp->st_atime = _toutc(statbufp->st_atime);
4768       statbufp->st_ctime = _toutc(statbufp->st_ctime);
4769     }
4770 #endif
4771     return 0;
4772   }
4773   return -1;
4774
4775 }  /* end of flex_fstat() */
4776 /*}}}*/
4777
4778 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4779 int
4780 flex_stat(const char *fspec, Stat_t *statbufp)
4781 {
4782     dTHX;
4783     char fileified[NAM$C_MAXRSS+1];
4784     char temp_fspec[NAM$C_MAXRSS+300];
4785     int retval = -1;
4786
4787     strcpy(temp_fspec, fspec);
4788     if (statbufp == (Stat_t *) &PL_statcache)
4789       do_tovmsspec(temp_fspec,namecache,0);
4790     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4791       memset(statbufp,0,sizeof *statbufp);
4792       statbufp->st_dev = encode_dev("_NLA0:");
4793       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4794       statbufp->st_uid = 0x00010001;
4795       statbufp->st_gid = 0x0001;
4796       time((time_t *)&statbufp->st_mtime);
4797       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4798       return 0;
4799     }
4800
4801     /* Try for a directory name first.  If fspec contains a filename without
4802      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4803      * and sea:[wine.dark]water. exist, we prefer the directory here.
4804      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4805      * not sea:[wine.dark]., if the latter exists.  If the intended target is
4806      * the file with null type, specify this by calling flex_stat() with
4807      * a '.' at the end of fspec.
4808      */
4809     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4810       retval = stat(fileified,(stat_t *) statbufp);
4811       if (!retval && statbufp == (Stat_t *) &PL_statcache)
4812         strcpy(namecache,fileified);
4813     }
4814     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4815     if (!retval) {
4816       statbufp->st_dev = encode_dev(statbufp->st_devnam);
4817 #     ifdef RTL_USES_UTC
4818 #     ifdef VMSISH_TIME
4819       if (VMSISH_TIME) {
4820         statbufp->st_mtime = _toloc(statbufp->st_mtime);
4821         statbufp->st_atime = _toloc(statbufp->st_atime);
4822         statbufp->st_ctime = _toloc(statbufp->st_ctime);
4823       }
4824 #     endif
4825 #     else
4826 #     ifdef VMSISH_TIME
4827       if (!VMSISH_TIME) { /* Return UTC instead of local time */
4828 #     else
4829       if (1) {
4830 #     endif
4831         statbufp->st_mtime = _toutc(statbufp->st_mtime);
4832         statbufp->st_atime = _toutc(statbufp->st_atime);
4833         statbufp->st_ctime = _toutc(statbufp->st_ctime);
4834       }
4835 #     endif
4836     }
4837     return retval;
4838
4839 }  /* end of flex_stat() */
4840 /*}}}*/
4841
4842
4843 /*{{{char *my_getlogin()*/
4844 /* VMS cuserid == Unix getlogin, except calling sequence */
4845 char *
4846 my_getlogin()
4847 {
4848     static char user[L_cuserid];
4849     return cuserid(user);
4850 }
4851 /*}}}*/
4852
4853
4854 /*  rmscopy - copy a file using VMS RMS routines
4855  *
4856  *  Copies contents and attributes of spec_in to spec_out, except owner
4857  *  and protection information.  Name and type of spec_in are used as
4858  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
4859  *  should try to propagate timestamps from the input file to the output file.
4860  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
4861  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
4862  *  propagated to the output file at creation iff the output file specification
4863  *  did not contain an explicit name or type, and the revision date is always
4864  *  updated at the end of the copy operation.  If it is greater than 0, then
4865  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4866  *  other than the revision date should be propagated, and bit 1 indicates
4867  *  that the revision date should be propagated.
4868  *
4869  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4870  *
4871  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4872  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
4873  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
4874  * as part of the Perl standard distribution under the terms of the
4875  * GNU General Public License or the Perl Artistic License.  Copies
4876  * of each may be found in the Perl standard distribution.
4877  */
4878 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4879 int
4880 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
4881 {
4882     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4883          rsa[NAM$C_MAXRSS], ubf[32256];
4884     unsigned long int i, sts, sts2;
4885     struct FAB fab_in, fab_out;
4886     struct RAB rab_in, rab_out;
4887     struct NAM nam;
4888     struct XABDAT xabdat;
4889     struct XABFHC xabfhc;
4890     struct XABRDT xabrdt;
4891     struct XABSUM xabsum;
4892
4893     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
4894         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4895       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4896       return 0;
4897     }
4898
4899     fab_in = cc$rms_fab;
4900     fab_in.fab$l_fna = vmsin;
4901     fab_in.fab$b_fns = strlen(vmsin);
4902     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4903     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4904     fab_in.fab$l_fop = FAB$M_SQO;
4905     fab_in.fab$l_nam =  &nam;
4906     fab_in.fab$l_xab = (void *) &xabdat;
4907
4908     nam = cc$rms_nam;
4909     nam.nam$l_rsa = rsa;
4910     nam.nam$b_rss = sizeof(rsa);
4911     nam.nam$l_esa = esa;
4912     nam.nam$b_ess = sizeof (esa);
4913     nam.nam$b_esl = nam.nam$b_rsl = 0;
4914
4915     xabdat = cc$rms_xabdat;        /* To get creation date */
4916     xabdat.xab$l_nxt = (void *) &xabfhc;
4917
4918     xabfhc = cc$rms_xabfhc;        /* To get record length */
4919     xabfhc.xab$l_nxt = (void *) &xabsum;
4920
4921     xabsum = cc$rms_xabsum;        /* To get key and area information */
4922
4923     if (!((sts = sys$open(&fab_in)) & 1)) {
4924       set_vaxc_errno(sts);
4925       switch (sts) {
4926         case RMS$_FNF: case RMS$_DNF:
4927           set_errno(ENOENT); break;
4928         case RMS$_DIR:
4929           set_errno(ENOTDIR); break;
4930         case RMS$_DEV:
4931           set_errno(ENODEV); break;
4932         case RMS$_SYN:
4933           set_errno(EINVAL); break;
4934         case RMS$_PRV:
4935           set_errno(EACCES); break;
4936         default:
4937           set_errno(EVMSERR);
4938       }
4939       return 0;
4940     }
4941
4942     fab_out = fab_in;
4943     fab_out.fab$w_ifi = 0;
4944     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4945     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4946     fab_out.fab$l_fop = FAB$M_SQO;
4947     fab_out.fab$l_fna = vmsout;
4948     fab_out.fab$b_fns = strlen(vmsout);
4949     fab_out.fab$l_dna = nam.nam$l_name;
4950     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4951
4952     if (preserve_dates == 0) {  /* Act like DCL COPY */
4953       nam.nam$b_nop = NAM$M_SYNCHK;
4954       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
4955       if (!((sts = sys$parse(&fab_out)) & 1)) {
4956         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4957         set_vaxc_errno(sts);
4958         return 0;
4959       }
4960       fab_out.fab$l_xab = (void *) &xabdat;
4961       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4962     }
4963     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
4964     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
4965       preserve_dates =0;      /* bitmask from this point forward   */
4966
4967     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4968     if (!((sts = sys$create(&fab_out)) & 1)) {
4969       set_vaxc_errno(sts);
4970       switch (sts) {
4971         case RMS$_DNF:
4972           set_errno(ENOENT); break;
4973         case RMS$_DIR:
4974           set_errno(ENOTDIR); break;
4975         case RMS$_DEV:
4976           set_errno(ENODEV); break;
4977         case RMS$_SYN:
4978           set_errno(EINVAL); break;
4979         case RMS$_PRV:
4980           set_errno(EACCES); break;
4981         default:
4982           set_errno(EVMSERR);
4983       }
4984       return 0;
4985     }
4986     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
4987     if (preserve_dates & 2) {
4988       /* sys$close() will process xabrdt, not xabdat */
4989       xabrdt = cc$rms_xabrdt;
4990 #ifndef __GNUC__
4991       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4992 #else
4993       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4994        * is unsigned long[2], while DECC & VAXC use a struct */
4995       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4996 #endif
4997       fab_out.fab$l_xab = (void *) &xabrdt;
4998     }
4999
5000     rab_in = cc$rms_rab;
5001     rab_in.rab$l_fab = &fab_in;
5002     rab_in.rab$l_rop = RAB$M_BIO;
5003     rab_in.rab$l_ubf = ubf;
5004     rab_in.rab$w_usz = sizeof ubf;
5005     if (!((sts = sys$connect(&rab_in)) & 1)) {
5006       sys$close(&fab_in); sys$close(&fab_out);
5007       set_errno(EVMSERR); set_vaxc_errno(sts);
5008       return 0;
5009     }
5010
5011     rab_out = cc$rms_rab;
5012     rab_out.rab$l_fab = &fab_out;
5013     rab_out.rab$l_rbf = ubf;
5014     if (!((sts = sys$connect(&rab_out)) & 1)) {
5015       sys$close(&fab_in); sys$close(&fab_out);
5016       set_errno(EVMSERR); set_vaxc_errno(sts);
5017       return 0;
5018     }
5019
5020     while ((sts = sys$read(&rab_in))) {  /* always true  */
5021       if (sts == RMS$_EOF) break;
5022       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
5023       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
5024         sys$close(&fab_in); sys$close(&fab_out);
5025         set_errno(EVMSERR); set_vaxc_errno(sts);
5026         return 0;
5027       }
5028     }
5029
5030     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
5031     sys$close(&fab_in);  sys$close(&fab_out);
5032     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5033     if (!(sts & 1)) {
5034       set_errno(EVMSERR); set_vaxc_errno(sts);
5035       return 0;
5036     }
5037
5038     return 1;
5039
5040 }  /* end of rmscopy() */
5041 /*}}}*/
5042
5043
5044 /***  The following glue provides 'hooks' to make some of the routines
5045  * from this file available from Perl.  These routines are sufficiently
5046  * basic, and are required sufficiently early in the build process,
5047  * that's it's nice to have them available to miniperl as well as the
5048  * full Perl, so they're set up here instead of in an extension.  The
5049  * Perl code which handles importation of these names into a given
5050  * package lives in [.VMS]Filespec.pm in @INC.
5051  */
5052
5053 void
5054 rmsexpand_fromperl(pTHX_ CV *cv)
5055 {
5056   dXSARGS;
5057   char *fspec, *defspec = NULL, *rslt;
5058   STRLEN n_a;
5059
5060   if (!items || items > 2)
5061     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5062   fspec = SvPV(ST(0),n_a);
5063   if (!fspec || !*fspec) XSRETURN_UNDEF;
5064   if (items == 2) defspec = SvPV(ST(1),n_a);
5065
5066   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5067   ST(0) = sv_newmortal();
5068   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5069   XSRETURN(1);
5070 }
5071
5072 void
5073 vmsify_fromperl(pTHX_ CV *cv)
5074 {
5075   dXSARGS;
5076   char *vmsified;
5077   STRLEN n_a;
5078
5079   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5080   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5081   ST(0) = sv_newmortal();
5082   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5083   XSRETURN(1);
5084 }
5085
5086 void
5087 unixify_fromperl(pTHX_ CV *cv)
5088 {
5089   dXSARGS;
5090   char *unixified;
5091   STRLEN n_a;
5092
5093   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5094   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5095   ST(0) = sv_newmortal();
5096   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5097   XSRETURN(1);
5098 }
5099
5100 void
5101 fileify_fromperl(pTHX_ CV *cv)
5102 {
5103   dXSARGS;
5104   char *fileified;
5105   STRLEN n_a;
5106
5107   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5108   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5109   ST(0) = sv_newmortal();
5110   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5111   XSRETURN(1);
5112 }
5113
5114 void
5115 pathify_fromperl(pTHX_ CV *cv)
5116 {
5117   dXSARGS;
5118   char *pathified;
5119   STRLEN n_a;
5120
5121   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5122   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5123   ST(0) = sv_newmortal();
5124   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5125   XSRETURN(1);
5126 }
5127
5128 void
5129 vmspath_fromperl(pTHX_ CV *cv)
5130 {
5131   dXSARGS;
5132   char *vmspath;
5133   STRLEN n_a;
5134
5135   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5136   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5137   ST(0) = sv_newmortal();
5138   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5139   XSRETURN(1);
5140 }
5141
5142 void
5143 unixpath_fromperl(pTHX_ CV *cv)
5144 {
5145   dXSARGS;
5146   char *unixpath;
5147   STRLEN n_a;
5148
5149   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5150   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5151   ST(0) = sv_newmortal();
5152   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5153   XSRETURN(1);
5154 }
5155
5156 void
5157 candelete_fromperl(pTHX_ CV *cv)
5158 {
5159   dXSARGS;
5160   char fspec[NAM$C_MAXRSS+1], *fsp;
5161   SV *mysv;
5162   IO *io;
5163   STRLEN n_a;
5164
5165   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5166
5167   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5168   if (SvTYPE(mysv) == SVt_PVGV) {
5169     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5170       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5171       ST(0) = &PL_sv_no;
5172       XSRETURN(1);
5173     }
5174     fsp = fspec;
5175   }
5176   else {
5177     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5178       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5179       ST(0) = &PL_sv_no;
5180       XSRETURN(1);
5181     }
5182   }
5183
5184   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5185   XSRETURN(1);
5186 }
5187
5188 void
5189 rmscopy_fromperl(pTHX_ CV *cv)
5190 {
5191   dXSARGS;
5192   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5193   int date_flag;
5194   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5195                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5196   unsigned long int sts;
5197   SV *mysv;
5198   IO *io;
5199   STRLEN n_a;
5200
5201   if (items < 2 || items > 3)
5202     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5203
5204   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5205   if (SvTYPE(mysv) == SVt_PVGV) {
5206     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5207       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5208       ST(0) = &PL_sv_no;
5209       XSRETURN(1);
5210     }
5211     inp = inspec;
5212   }
5213   else {
5214     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5215       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5216       ST(0) = &PL_sv_no;
5217       XSRETURN(1);
5218     }
5219   }
5220   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5221   if (SvTYPE(mysv) == SVt_PVGV) {
5222     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5223       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5224       ST(0) = &PL_sv_no;
5225       XSRETURN(1);
5226     }
5227     outp = outspec;
5228   }
5229   else {
5230     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5231       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5232       ST(0) = &PL_sv_no;
5233       XSRETURN(1);
5234     }
5235   }
5236   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5237
5238   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5239   XSRETURN(1);
5240 }
5241
5242
5243 void
5244 mod2fname(CV *cv)
5245 {
5246   dXSARGS;
5247   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
5248        workbuff[NAM$C_MAXRSS*1 + 1];
5249   int total_namelen = 3, counter, num_entries;
5250   /* ODS-5 ups this, but we want to be consistent, so... */
5251   int max_name_len = 39;
5252   AV *in_array = (AV *)SvRV(ST(0));
5253
5254   num_entries = av_len(in_array);
5255
5256   /* All the names start with PL_. */
5257   strcpy(ultimate_name, "PL_");
5258
5259   /* Clean up our working buffer */
5260   Zero(work_name, sizeof(work_name), char);
5261
5262   /* Run through the entries and build up a working name */
5263   for(counter = 0; counter <= num_entries; counter++) {
5264     /* If it's not the first name then tack on a __ */
5265     if (counter) {
5266       strcat(work_name, "__");
5267     }
5268     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
5269                            PL_na));
5270   }
5271
5272   /* Check to see if we actually have to bother...*/
5273   if (strlen(work_name) + 3 <= max_name_len) {
5274     strcat(ultimate_name, work_name);
5275   } else {
5276     /* It's too darned big, so we need to go strip. We use the same */
5277     /* algorithm as xsubpp does. First, strip out doubled __ */
5278     char *source, *dest, last;
5279     dest = workbuff;
5280     last = 0;
5281     for (source = work_name; *source; source++) {
5282       if (last == *source && last == '_') {
5283         continue;
5284       }
5285       *dest++ = *source;
5286       last = *source;
5287     }
5288     /* Go put it back */
5289     strcpy(work_name, workbuff);
5290     /* Is it still too big? */
5291     if (strlen(work_name) + 3 > max_name_len) {
5292       /* Strip duplicate letters */
5293       last = 0;
5294       dest = workbuff;
5295       for (source = work_name; *source; source++) {
5296         if (last == toupper(*source)) {
5297         continue;
5298         }
5299         *dest++ = *source;
5300         last = toupper(*source);
5301       }
5302       strcpy(work_name, workbuff);
5303     }
5304
5305     /* Is it *still* too big? */
5306     if (strlen(work_name) + 3 > max_name_len) {
5307       /* Too bad, we truncate */
5308       work_name[max_name_len - 2] = 0;
5309     }
5310     strcat(ultimate_name, work_name);
5311   }
5312
5313   /* Okay, return it */
5314   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
5315   XSRETURN(1);
5316 }
5317
5318 void
5319 init_os_extras()
5320 {
5321   char* file = __FILE__;
5322   dTHX;
5323   char temp_buff[512];
5324   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5325     no_translate_barewords = TRUE;
5326   } else {
5327     no_translate_barewords = FALSE;
5328   }
5329
5330   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5331   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5332   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5333   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5334   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5335   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5336   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5337   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5338   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
5339   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
5340
5341   return;
5342 }
5343
5344 /*  End of vms.c */