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        */
2904       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2905       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2906       jpilist[1].buflen = rsz * sizeof(unsigned long int);
2907       _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2908       _ckvmssts(iosb[0]);
2909     }
2910     mask = jpilist[1].bufadr;
2911     /* Check attribute flags for each identifier (2nd longword); protected
2912      * subsystem identifiers trigger tainting.
2913      */
2914     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2915       if (mask[i] & KGB$M_SUBSYSTEM) {
2916         will_taint = TRUE;
2917         break;
2918       }
2919     }
2920     if (mask != rlst) Safefree(mask);
2921   }
2922   /* We need to use this hack to tell Perl it should run with tainting,
2923    * since its tainting flag may be part of the PL_curinterp struct, which
2924    * hasn't been allocated when vms_image_init() is called.
2925    */
2926   if (will_taint) {
2927     char ***newap;
2928     New(1320,newap,*argcp+2,char **);
2929     newap[0] = argvp[0];
2930     *newap[1] = "-T";
2931     Copy(argvp[1],newap[2],*argcp-1,char **);
2932     /* We orphan the old argv, since we don't know where it's come from,
2933      * so we don't know how to free it.
2934      */
2935     *argcp++; argvp = newap;
2936   }
2937   else {  /* Did user explicitly request tainting? */
2938     int i;
2939     char *cp, **av = *argvp;
2940     for (i = 1; i < *argcp; i++) {
2941       if (*av[i] != '-') break;
2942       for (cp = av[i]+1; *cp; cp++) {
2943         if (*cp == 'T') { will_taint = 1; break; }
2944         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2945                   strchr("DFIiMmx",*cp)) break;
2946       }
2947       if (will_taint) break;
2948     }
2949   }
2950
2951   for (tabidx = 0;
2952        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2953        tabidx++) {
2954     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2955     else if (tabidx >= tabct) {
2956       tabct += 8;
2957       Renew(tabvec,tabct,struct dsc$descriptor_s *);
2958     }
2959     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2960     tabvec[tabidx]->dsc$w_length  = 0;
2961     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
2962     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
2963     tabvec[tabidx]->dsc$a_pointer = NULL;
2964     _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2965   }
2966   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2967
2968   getredirection(argcp,argvp);
2969 #if defined(USE_THREADS) && defined(__DECC)
2970   {
2971 # include <reentrancy.h>
2972   (void) decc$set_reentrancy(C$C_MULTITHREAD);
2973   }
2974 #endif
2975   return;
2976 }
2977 /*}}}*/
2978
2979
2980 /* trim_unixpath()
2981  * Trim Unix-style prefix off filespec, so it looks like what a shell
2982  * glob expansion would return (i.e. from specified prefix on, not
2983  * full path).  Note that returned filespec is Unix-style, regardless
2984  * of whether input filespec was VMS-style or Unix-style.
2985  *
2986  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2987  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
2988  * vector of options; at present, only bit 0 is used, and if set tells
2989  * trim unixpath to try the current default directory as a prefix when
2990  * presented with a possibly ambiguous ... wildcard.
2991  *
2992  * Returns !=0 on success, with trimmed filespec replacing contents of
2993  * fspec, and 0 on failure, with contents of fpsec unchanged.
2994  */
2995 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2996 int
2997 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
2998 {
2999   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3000        *template, *base, *end, *cp1, *cp2;
3001   register int tmplen, reslen = 0, dirs = 0;
3002
3003   if (!wildspec || !fspec) return 0;
3004   if (strpbrk(wildspec,"]>:") != NULL) {
3005     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3006     else template = unixwild;
3007   }
3008   else template = wildspec;
3009   if (strpbrk(fspec,"]>:") != NULL) {
3010     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3011     else base = unixified;
3012     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
3013      * check to see that final result fits into (isn't longer than) fspec */
3014     reslen = strlen(fspec);
3015   }
3016   else base = fspec;
3017
3018   /* No prefix or absolute path on wildcard, so nothing to remove */
3019   if (!*template || *template == '/') {
3020     if (base == fspec) return 1;
3021     tmplen = strlen(unixified);
3022     if (tmplen > reslen) return 0;  /* not enough space */
3023     /* Copy unixified resultant, including trailing NUL */
3024     memmove(fspec,unixified,tmplen+1);
3025     return 1;
3026   }
3027
3028   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
3029   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3030     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3031     for (cp1 = end ;cp1 >= base; cp1--)
3032       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3033         { cp1++; break; }
3034     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3035     return 1;
3036   }
3037   else {
3038     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3039     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3040     int ells = 1, totells, segdirs, match;
3041     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3042                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3043
3044     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3045     totells = ells;
3046     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3047     if (ellipsis == template && opts & 1) {
3048       /* Template begins with an ellipsis.  Since we can't tell how many
3049        * directory names at the front of the resultant to keep for an
3050        * arbitrary starting point, we arbitrarily choose the current
3051        * default directory as a starting point.  If it's there as a prefix,
3052        * clip it off.  If not, fall through and act as if the leading
3053        * ellipsis weren't there (i.e. return shortest possible path that
3054        * could match template).
3055        */
3056       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3057       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3058         if (_tolower(*cp1) != _tolower(*cp2)) break;
3059       segdirs = dirs - totells;  /* Min # of dirs we must have left */
3060       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3061       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3062         memcpy(fspec,cp2+1,end - cp2);
3063         return 1;
3064       }
3065     }
3066     /* First off, back up over constant elements at end of path */
3067     if (dirs) {
3068       for (front = end ; front >= base; front--)
3069          if (*front == '/' && !dirs--) { front++; break; }
3070     }
3071     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3072          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
3073     if (cp1 != '\0') return 0;  /* Path too long. */
3074     lcend = cp2;
3075     *cp2 = '\0';  /* Pick up with memcpy later */
3076     lcfront = lcres + (front - base);
3077     /* Now skip over each ellipsis and try to match the path in front of it. */
3078     while (ells--) {
3079       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3080         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
3081             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
3082       if (cp1 < template) break; /* template started with an ellipsis */
3083       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3084         ellipsis = cp1; continue;
3085       }
3086       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3087       nextell = cp1;
3088       for (segdirs = 0, cp2 = tpl;
3089            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3090            cp1++, cp2++) {
3091          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3092          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
3093          if (*cp2 == '/') segdirs++;
3094       }
3095       if (cp1 != ellipsis - 1) return 0; /* Path too long */
3096       /* Back up at least as many dirs as in template before matching */
3097       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3098         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3099       for (match = 0; cp1 > lcres;) {
3100         resdsc.dsc$a_pointer = cp1;
3101         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3102           match++;
3103           if (match == 1) lcfront = cp1;
3104         }
3105         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3106       }
3107       if (!match) return 0;  /* Can't find prefix ??? */
3108       if (match > 1 && opts & 1) {
3109         /* This ... wildcard could cover more than one set of dirs (i.e.
3110          * a set of similar dir names is repeated).  If the template
3111          * contains more than 1 ..., upstream elements could resolve the
3112          * ambiguity, but it's not worth a full backtracking setup here.
3113          * As a quick heuristic, clip off the current default directory
3114          * if it's present to find the trimmed spec, else use the
3115          * shortest string that this ... could cover.
3116          */
3117         char def[NAM$C_MAXRSS+1], *st;
3118
3119         if (getcwd(def, sizeof def,0) == NULL) return 0;
3120         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3121           if (_tolower(*cp1) != _tolower(*cp2)) break;
3122         segdirs = dirs - totells;  /* Min # of dirs we must have left */
3123         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3124         if (*cp1 == '\0' && *cp2 == '/') {
3125           memcpy(fspec,cp2+1,end - cp2);
3126           return 1;
3127         }
3128         /* Nope -- stick with lcfront from above and keep going. */
3129       }
3130     }
3131     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3132     return 1;
3133     ellipsis = nextell;
3134   }
3135
3136 }  /* end of trim_unixpath() */
3137 /*}}}*/
3138
3139
3140 /*
3141  *  VMS readdir() routines.
3142  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3143  *
3144  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
3145  *  Minor modifications to original routines.
3146  */
3147
3148     /* Number of elements in vms_versions array */
3149 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
3150
3151 /*
3152  *  Open a directory, return a handle for later use.
3153  */
3154 /*{{{ DIR *opendir(char*name) */
3155 DIR *
3156 Perl_opendir(pTHX_ char *name)
3157 {
3158     DIR *dd;
3159     char dir[NAM$C_MAXRSS+1];
3160     Stat_t sb;
3161
3162     if (do_tovmspath(name,dir,0) == NULL) {
3163       return NULL;
3164     }
3165     if (flex_stat(dir,&sb) == -1) return NULL;
3166     if (!S_ISDIR(sb.st_mode)) {
3167       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
3168       return NULL;
3169     }
3170     if (!cando_by_name(S_IRUSR,0,dir)) {
3171       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3172       return NULL;
3173     }
3174     /* Get memory for the handle, and the pattern. */
3175     New(1306,dd,1,DIR);
3176     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3177
3178     /* Fill in the fields; mainly playing with the descriptor. */
3179     (void)sprintf(dd->pattern, "%s*.*",dir);
3180     dd->context = 0;
3181     dd->count = 0;
3182     dd->vms_wantversions = 0;
3183     dd->pat.dsc$a_pointer = dd->pattern;
3184     dd->pat.dsc$w_length = strlen(dd->pattern);
3185     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3186     dd->pat.dsc$b_class = DSC$K_CLASS_S;
3187
3188     return dd;
3189 }  /* end of opendir() */
3190 /*}}}*/
3191
3192 /*
3193  *  Set the flag to indicate we want versions or not.
3194  */
3195 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3196 void
3197 vmsreaddirversions(DIR *dd, int flag)
3198 {
3199     dd->vms_wantversions = flag;
3200 }
3201 /*}}}*/
3202
3203 /*
3204  *  Free up an opened directory.
3205  */
3206 /*{{{ void closedir(DIR *dd)*/
3207 void
3208 closedir(DIR *dd)
3209 {
3210     (void)lib$find_file_end(&dd->context);
3211     Safefree(dd->pattern);
3212     Safefree((char *)dd);
3213 }
3214 /*}}}*/
3215
3216 /*
3217  *  Collect all the version numbers for the current file.
3218  */
3219 static void
3220 collectversions(dd)
3221     DIR *dd;
3222 {
3223     struct dsc$descriptor_s     pat;
3224     struct dsc$descriptor_s     res;
3225     struct dirent *e;
3226     char *p, *text, buff[sizeof dd->entry.d_name];
3227     int i;
3228     unsigned long context, tmpsts;
3229     dTHX;
3230
3231     /* Convenient shorthand. */
3232     e = &dd->entry;
3233
3234     /* Add the version wildcard, ignoring the "*.*" put on before */
3235     i = strlen(dd->pattern);
3236     New(1308,text,i + e->d_namlen + 3,char);
3237     (void)strcpy(text, dd->pattern);
3238     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3239
3240     /* Set up the pattern descriptor. */
3241     pat.dsc$a_pointer = text;
3242     pat.dsc$w_length = i + e->d_namlen - 1;
3243     pat.dsc$b_dtype = DSC$K_DTYPE_T;
3244     pat.dsc$b_class = DSC$K_CLASS_S;
3245
3246     /* Set up result descriptor. */
3247     res.dsc$a_pointer = buff;
3248     res.dsc$w_length = sizeof buff - 2;
3249     res.dsc$b_dtype = DSC$K_DTYPE_T;
3250     res.dsc$b_class = DSC$K_CLASS_S;
3251
3252     /* Read files, collecting versions. */
3253     for (context = 0, e->vms_verscount = 0;
3254          e->vms_verscount < VERSIZE(e);
3255          e->vms_verscount++) {
3256         tmpsts = lib$find_file(&pat, &res, &context);
3257         if (tmpsts == RMS$_NMF || context == 0) break;
3258         _ckvmssts(tmpsts);
3259         buff[sizeof buff - 1] = '\0';
3260         if ((p = strchr(buff, ';')))
3261             e->vms_versions[e->vms_verscount] = atoi(p + 1);
3262         else
3263             e->vms_versions[e->vms_verscount] = -1;
3264     }
3265
3266     _ckvmssts(lib$find_file_end(&context));
3267     Safefree(text);
3268
3269 }  /* end of collectversions() */
3270
3271 /*
3272  *  Read the next entry from the directory.
3273  */
3274 /*{{{ struct dirent *readdir(DIR *dd)*/
3275 struct dirent *
3276 readdir(DIR *dd)
3277 {
3278     struct dsc$descriptor_s     res;
3279     char *p, buff[sizeof dd->entry.d_name];
3280     unsigned long int tmpsts;
3281
3282     /* Set up result descriptor, and get next file. */
3283     res.dsc$a_pointer = buff;
3284     res.dsc$w_length = sizeof buff - 2;
3285     res.dsc$b_dtype = DSC$K_DTYPE_T;
3286     res.dsc$b_class = DSC$K_CLASS_S;
3287     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3288     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
3289     if (!(tmpsts & 1)) {
3290       set_vaxc_errno(tmpsts);
3291       switch (tmpsts) {
3292         case RMS$_PRV:
3293           set_errno(EACCES); break;
3294         case RMS$_DEV:
3295           set_errno(ENODEV); break;
3296         case RMS$_DIR:
3297           set_errno(ENOTDIR); break;
3298         case RMS$_FNF: case RMS$_DNF:
3299           set_errno(ENOENT); break;
3300         default:
3301           set_errno(EVMSERR);
3302       }
3303       return NULL;
3304     }
3305     dd->count++;
3306     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3307     buff[sizeof buff - 1] = '\0';
3308     for (p = buff; *p; p++) *p = _tolower(*p);
3309     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
3310     *p = '\0';
3311
3312     /* Skip any directory component and just copy the name. */
3313     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3314     else (void)strcpy(dd->entry.d_name, buff);
3315
3316     /* Clobber the version. */
3317     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3318
3319     dd->entry.d_namlen = strlen(dd->entry.d_name);
3320     dd->entry.vms_verscount = 0;
3321     if (dd->vms_wantversions) collectversions(dd);
3322     return &dd->entry;
3323
3324 }  /* end of readdir() */
3325 /*}}}*/
3326
3327 /*
3328  *  Return something that can be used in a seekdir later.
3329  */
3330 /*{{{ long telldir(DIR *dd)*/
3331 long
3332 telldir(DIR *dd)
3333 {
3334     return dd->count;
3335 }
3336 /*}}}*/
3337
3338 /*
3339  *  Return to a spot where we used to be.  Brute force.
3340  */
3341 /*{{{ void seekdir(DIR *dd,long count)*/
3342 void
3343 seekdir(DIR *dd, long count)
3344 {
3345     int vms_wantversions;
3346     dTHX;
3347
3348     /* If we haven't done anything yet... */
3349     if (dd->count == 0)
3350         return;
3351
3352     /* Remember some state, and clear it. */
3353     vms_wantversions = dd->vms_wantversions;
3354     dd->vms_wantversions = 0;
3355     _ckvmssts(lib$find_file_end(&dd->context));
3356     dd->context = 0;
3357
3358     /* The increment is in readdir(). */
3359     for (dd->count = 0; dd->count < count; )
3360         (void)readdir(dd);
3361
3362     dd->vms_wantversions = vms_wantversions;
3363
3364 }  /* end of seekdir() */
3365 /*}}}*/
3366
3367 /* VMS subprocess management
3368  *
3369  * my_vfork() - just a vfork(), after setting a flag to record that
3370  * the current script is trying a Unix-style fork/exec.
3371  *
3372  * vms_do_aexec() and vms_do_exec() are called in response to the
3373  * perl 'exec' function.  If this follows a vfork call, then they
3374  * call out the the regular perl routines in doio.c which do an
3375  * execvp (for those who really want to try this under VMS).
3376  * Otherwise, they do exactly what the perl docs say exec should
3377  * do - terminate the current script and invoke a new command
3378  * (See below for notes on command syntax.)
3379  *
3380  * do_aspawn() and do_spawn() implement the VMS side of the perl
3381  * 'system' function.
3382  *
3383  * Note on command arguments to perl 'exec' and 'system': When handled
3384  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3385  * are concatenated to form a DCL command string.  If the first arg
3386  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3387  * the the command string is handed off to DCL directly.  Otherwise,
3388  * the first token of the command is taken as the filespec of an image
3389  * to run.  The filespec is expanded using a default type of '.EXE' and
3390  * the process defaults for device, directory, etc., and if found, the resultant
3391  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3392  * the command string as parameters.  This is perhaps a bit complicated,
3393  * but I hope it will form a happy medium between what VMS folks expect
3394  * from lib$spawn and what Unix folks expect from exec.
3395  */
3396
3397 static int vfork_called;
3398
3399 /*{{{int my_vfork()*/
3400 int
3401 my_vfork()
3402 {
3403   vfork_called++;
3404   return vfork();
3405 }
3406 /*}}}*/
3407
3408
3409 static void
3410 vms_execfree(pTHX) {
3411   if (PL_Cmd) {
3412     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3413     PL_Cmd = Nullch;
3414   }
3415   if (VMScmd.dsc$a_pointer) {
3416     Safefree(VMScmd.dsc$a_pointer);
3417     VMScmd.dsc$w_length = 0;
3418     VMScmd.dsc$a_pointer = Nullch;
3419   }
3420 }
3421
3422 static char *
3423 setup_argstr(SV *really, SV **mark, SV **sp)
3424 {
3425   dTHX;
3426   char *junk, *tmps = Nullch;
3427   register size_t cmdlen = 0;
3428   size_t rlen;
3429   register SV **idx;
3430   STRLEN n_a;
3431
3432   idx = mark;
3433   if (really) {
3434     tmps = SvPV(really,rlen);
3435     if (*tmps) {
3436       cmdlen += rlen + 1;
3437       idx++;
3438     }
3439   }
3440
3441   for (idx++; idx <= sp; idx++) {
3442     if (*idx) {
3443       junk = SvPVx(*idx,rlen);
3444       cmdlen += rlen ? rlen + 1 : 0;
3445     }
3446   }
3447   New(401,PL_Cmd,cmdlen+1,char);
3448
3449   if (tmps && *tmps) {
3450     strcpy(PL_Cmd,tmps);
3451     mark++;
3452   }
3453   else *PL_Cmd = '\0';
3454   while (++mark <= sp) {
3455     if (*mark) {
3456       char *s = SvPVx(*mark,n_a);
3457       if (!*s) continue;
3458       if (*PL_Cmd) strcat(PL_Cmd," ");
3459       strcat(PL_Cmd,s);
3460     }
3461   }
3462   return PL_Cmd;
3463
3464 }  /* end of setup_argstr() */
3465
3466
3467 static unsigned long int
3468 setup_cmddsc(char *cmd, int check_img)
3469 {
3470   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3471   $DESCRIPTOR(defdsc,".EXE");
3472   $DESCRIPTOR(defdsc2,".");
3473   $DESCRIPTOR(resdsc,resspec);
3474   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3475   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3476   register char *s, *rest, *cp, *wordbreak;
3477   register int isdcl;
3478   dTHX;
3479
3480   if (strlen(cmd) >
3481       (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3482     return LIB$_INVARG;
3483   s = cmd;
3484   while (*s && isspace(*s)) s++;
3485
3486   if (*s == '@' || *s == '$') {
3487     vmsspec[0] = *s;  rest = s + 1;
3488     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3489   }
3490   else { cp = vmsspec; rest = s; }
3491   if (*rest == '.' || *rest == '/') {
3492     char *cp2;
3493     for (cp2 = resspec;
3494          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3495          rest++, cp2++) *cp2 = *rest;
3496     *cp2 = '\0';
3497     if (do_tovmsspec(resspec,cp,0)) {
3498       s = vmsspec;
3499       if (*rest) {
3500         for (cp2 = vmsspec + strlen(vmsspec);
3501              *rest && cp2 - vmsspec < sizeof vmsspec;
3502              rest++, cp2++) *cp2 = *rest;
3503         *cp2 = '\0';
3504       }
3505     }
3506   }
3507   /* Intuit whether verb (first word of cmd) is a DCL command:
3508    *   - if first nonspace char is '@', it's a DCL indirection
3509    * otherwise
3510    *   - if verb contains a filespec separator, it's not a DCL command
3511    *   - if it doesn't, caller tells us whether to default to a DCL
3512    *     command, or to a local image unless told it's DCL (by leading '$')
3513    */
3514   if (*s == '@') isdcl = 1;
3515   else {
3516     register char *filespec = strpbrk(s,":<[.;");
3517     rest = wordbreak = strpbrk(s," \"\t/");
3518     if (!wordbreak) wordbreak = s + strlen(s);
3519     if (*s == '$') check_img = 0;
3520     if (filespec && (filespec < wordbreak)) isdcl = 0;
3521     else isdcl = !check_img;
3522   }
3523
3524   if (!isdcl) {
3525     imgdsc.dsc$a_pointer = s;
3526     imgdsc.dsc$w_length = wordbreak - s;
3527     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3528     if (!(retsts&1)) {
3529         _ckvmssts(lib$find_file_end(&cxt));
3530         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3531     if (!(retsts & 1) && *s == '$') {
3532           _ckvmssts(lib$find_file_end(&cxt));
3533       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3534       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3535           if (!(retsts&1)) {
3536       _ckvmssts(lib$find_file_end(&cxt));
3537             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3538           }
3539     }
3540     }
3541     _ckvmssts(lib$find_file_end(&cxt));
3542
3543     if (retsts & 1) {
3544       FILE *fp;
3545       s = resspec;
3546       while (*s && !isspace(*s)) s++;
3547       *s = '\0';
3548
3549       /* check that it's really not DCL with no file extension */
3550       fp = fopen(resspec,"r","ctx=bin,shr=get");
3551       if (fp) {
3552         char b[4] = {0,0,0,0};
3553         read(fileno(fp),b,4);
3554         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3555         fclose(fp);
3556       }
3557       if (check_img && isdcl) return RMS$_FNF;
3558
3559       if (cando_by_name(S_IXUSR,0,resspec)) {
3560         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3561         if (!isdcl) {
3562         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3563         } else {
3564             strcpy(VMScmd.dsc$a_pointer,"@");
3565         }
3566         strcat(VMScmd.dsc$a_pointer,resspec);
3567         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3568         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3569         return retsts;
3570       }
3571       else retsts = RMS$_PRV;
3572     }
3573   }
3574   /* It's either a DCL command or we couldn't find a suitable image */
3575   VMScmd.dsc$w_length = strlen(cmd);
3576   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3577   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3578   if (!(retsts & 1)) {
3579     /* just hand off status values likely to be due to user error */
3580     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3581         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3582        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3583     else { _ckvmssts(retsts); }
3584   }
3585
3586   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3587
3588 }  /* end of setup_cmddsc() */
3589
3590
3591 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3592 bool
3593 vms_do_aexec(SV *really,SV **mark,SV **sp)
3594 {
3595   dTHX;
3596   if (sp > mark) {
3597     if (vfork_called) {           /* this follows a vfork - act Unixish */
3598       vfork_called--;
3599       if (vfork_called < 0) {
3600         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3601         vfork_called = 0;
3602       }
3603       else return do_aexec(really,mark,sp);
3604     }
3605                                            /* no vfork - act VMSish */
3606     return vms_do_exec(setup_argstr(really,mark,sp));
3607
3608   }
3609
3610   return FALSE;
3611 }  /* end of vms_do_aexec() */
3612 /*}}}*/
3613
3614 /* {{{bool vms_do_exec(char *cmd) */
3615 bool
3616 vms_do_exec(char *cmd)
3617 {
3618
3619   dTHX;
3620   if (vfork_called) {             /* this follows a vfork - act Unixish */
3621     vfork_called--;
3622     if (vfork_called < 0) {
3623       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3624       vfork_called = 0;
3625     }
3626     else return do_exec(cmd);
3627   }
3628
3629   {                               /* no vfork - act VMSish */
3630     unsigned long int retsts;
3631
3632     TAINT_ENV();
3633     TAINT_PROPER("exec");
3634     if ((retsts = setup_cmddsc(cmd,1)) & 1)
3635       retsts = lib$do_command(&VMScmd);
3636
3637     switch (retsts) {
3638       case RMS$_FNF: case RMS$_DNF:
3639         set_errno(ENOENT); break;
3640       case RMS$_DIR:
3641         set_errno(ENOTDIR); break;
3642       case RMS$_DEV:
3643         set_errno(ENODEV); break;
3644       case RMS$_PRV:
3645         set_errno(EACCES); break;
3646       case RMS$_SYN:
3647         set_errno(EINVAL); break;
3648       case CLI$_BUFOVF:
3649         set_errno(E2BIG); break;
3650       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3651         _ckvmssts(retsts); /* fall through */
3652       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3653         set_errno(EVMSERR);
3654     }
3655     set_vaxc_errno(retsts);
3656     if (ckWARN(WARN_EXEC)) {
3657       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3658              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3659     }
3660     vms_execfree(aTHX);
3661   }
3662
3663   return FALSE;
3664
3665 }  /* end of vms_do_exec() */
3666 /*}}}*/
3667
3668 unsigned long int do_spawn(char *);
3669
3670 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3671 unsigned long int
3672 do_aspawn(void *really,void **mark,void **sp)
3673 {
3674   dTHX;
3675   if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3676
3677   return SS$_ABORT;
3678 }  /* end of do_aspawn() */
3679 /*}}}*/
3680
3681 /* {{{unsigned long int do_spawn(char *cmd) */
3682 unsigned long int
3683 do_spawn(char *cmd)
3684 {
3685   unsigned long int sts, substs, hadcmd = 1;
3686   dTHX;
3687
3688   TAINT_ENV();
3689   TAINT_PROPER("spawn");
3690   if (!cmd || !*cmd) {
3691     hadcmd = 0;
3692     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3693   }
3694   else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3695     sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3696   }
3697
3698   if (!(sts & 1)) {
3699     switch (sts) {
3700       case RMS$_FNF:  case RMS$_DNF:
3701         set_errno(ENOENT); break;
3702       case RMS$_DIR:
3703         set_errno(ENOTDIR); break;
3704       case RMS$_DEV:
3705         set_errno(ENODEV); break;
3706       case RMS$_PRV:
3707         set_errno(EACCES); break;
3708       case RMS$_SYN:
3709         set_errno(EINVAL); break;
3710       case CLI$_BUFOVF:
3711         set_errno(E2BIG); break;
3712       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3713         _ckvmssts(sts); /* fall through */
3714       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3715         set_errno(EVMSERR);
3716     }
3717     set_vaxc_errno(sts);
3718     if (ckWARN(WARN_EXEC)) {
3719       Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3720              hadcmd ? VMScmd.dsc$w_length :  0,
3721              hadcmd ? VMScmd.dsc$a_pointer : "",
3722              Strerror(errno));
3723     }
3724   }
3725   vms_execfree(aTHX);
3726   return substs;
3727
3728 }  /* end of do_spawn() */
3729 /*}}}*/
3730
3731 /*
3732  * A simple fwrite replacement which outputs itmsz*nitm chars without
3733  * introducing record boundaries every itmsz chars.
3734  */
3735 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3736 int
3737 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3738 {
3739   register char *cp, *end;
3740
3741   end = (char *)src + itmsz * nitm;
3742
3743   while ((char *)src <= end) {
3744     for (cp = src; cp <= end; cp++) if (!*cp) break;
3745     if (fputs(src,dest) == EOF) return EOF;
3746     if (cp < end)
3747       if (fputc('\0',dest) == EOF) return EOF;
3748     src = cp + 1;
3749   }
3750
3751   return 1;
3752
3753 }  /* end of my_fwrite() */
3754 /*}}}*/
3755
3756 /*{{{ int my_flush(FILE *fp)*/
3757 int
3758 my_flush(FILE *fp)
3759 {
3760     int res;
3761     if ((res = fflush(fp)) == 0 && fp) {
3762 #ifdef VMS_DO_SOCKETS
3763         Stat_t s;
3764         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3765 #endif
3766             res = fsync(fileno(fp));
3767     }
3768     return res;
3769 }
3770 /*}}}*/
3771
3772 /*
3773  * Here are replacements for the following Unix routines in the VMS environment:
3774  *      getpwuid    Get information for a particular UIC or UID
3775  *      getpwnam    Get information for a named user
3776  *      getpwent    Get information for each user in the rights database
3777  *      setpwent    Reset search to the start of the rights database
3778  *      endpwent    Finish searching for users in the rights database
3779  *
3780  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3781  * (defined in pwd.h), which contains the following fields:-
3782  *      struct passwd {
3783  *              char        *pw_name;    Username (in lower case)
3784  *              char        *pw_passwd;  Hashed password
3785  *              unsigned int pw_uid;     UIC
3786  *              unsigned int pw_gid;     UIC group  number
3787  *              char        *pw_unixdir; Default device/directory (VMS-style)
3788  *              char        *pw_gecos;   Owner name
3789  *              char        *pw_dir;     Default device/directory (Unix-style)
3790  *              char        *pw_shell;   Default CLI name (eg. DCL)
3791  *      };
3792  * If the specified user does not exist, getpwuid and getpwnam return NULL.
3793  *
3794  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3795  * not the UIC member number (eg. what's returned by getuid()),
3796  * getpwuid() can accept either as input (if uid is specified, the caller's
3797  * UIC group is used), though it won't recognise gid=0.
3798  *
3799  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3800  * information about other users in your group or in other groups, respectively.
3801  * If the required privilege is not available, then these routines fill only
3802  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3803  * string).
3804  *
3805  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3806  */
3807
3808 /* sizes of various UAF record fields */
3809 #define UAI$S_USERNAME 12
3810 #define UAI$S_IDENT    31
3811 #define UAI$S_OWNER    31
3812 #define UAI$S_DEFDEV   31
3813 #define UAI$S_DEFDIR   63
3814 #define UAI$S_DEFCLI   31
3815 #define UAI$S_PWD       8
3816
3817 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
3818                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3819                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
3820
3821 static char __empty[]= "";
3822 static struct passwd __passwd_empty=
3823     {(char *) __empty, (char *) __empty, 0, 0,
3824      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3825 static int contxt= 0;
3826 static struct passwd __pwdcache;
3827 static char __pw_namecache[UAI$S_IDENT+1];
3828
3829 /*
3830  * This routine does most of the work extracting the user information.
3831  */
3832 static int fillpasswd (const char *name, struct passwd *pwd)
3833 {
3834     dTHX;
3835     static struct {
3836         unsigned char length;
3837         char pw_gecos[UAI$S_OWNER+1];
3838     } owner;
3839     static union uicdef uic;
3840     static struct {
3841         unsigned char length;
3842         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3843     } defdev;
3844     static struct {
3845         unsigned char length;
3846         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3847     } defdir;
3848     static struct {
3849         unsigned char length;
3850         char pw_shell[UAI$S_DEFCLI+1];
3851     } defcli;
3852     static char pw_passwd[UAI$S_PWD+1];
3853
3854     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3855     struct dsc$descriptor_s name_desc;
3856     unsigned long int sts;
3857
3858     static struct itmlst_3 itmlst[]= {
3859         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
3860         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
3861         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
3862         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
3863         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
3864         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
3865         {0,                0,           NULL,    NULL}};
3866
3867     name_desc.dsc$w_length=  strlen(name);
3868     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3869     name_desc.dsc$b_class=   DSC$K_CLASS_S;
3870     name_desc.dsc$a_pointer= (char *) name;
3871
3872 /*  Note that sys$getuai returns many fields as counted strings. */
3873     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3874     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3875       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3876     }
3877     else { _ckvmssts(sts); }
3878     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
3879
3880     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
3881     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3882     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3883     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3884     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3885     owner.pw_gecos[lowner]=            '\0';
3886     defdev.pw_dir[ldefdev+ldefdir]= '\0';
3887     defcli.pw_shell[ldefcli]=          '\0';
3888     if (valid_uic(uic)) {
3889         pwd->pw_uid= uic.uic$l_uic;
3890         pwd->pw_gid= uic.uic$v_group;
3891     }
3892     else
3893       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3894     pwd->pw_passwd=  pw_passwd;
3895     pwd->pw_gecos=   owner.pw_gecos;
3896     pwd->pw_dir=     defdev.pw_dir;
3897     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3898     pwd->pw_shell=   defcli.pw_shell;
3899     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3900         int ldir;
3901         ldir= strlen(pwd->pw_unixdir) - 1;
3902         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3903     }
3904     else
3905         strcpy(pwd->pw_unixdir, pwd->pw_dir);
3906     __mystrtolower(pwd->pw_unixdir);
3907     return 1;
3908 }
3909
3910 /*
3911  * Get information for a named user.
3912 */
3913 /*{{{struct passwd *getpwnam(char *name)*/
3914 struct passwd *my_getpwnam(char *name)
3915 {
3916     struct dsc$descriptor_s name_desc;
3917     union uicdef uic;
3918     unsigned long int status, sts;
3919     dTHX;
3920
3921     __pwdcache = __passwd_empty;
3922     if (!fillpasswd(name, &__pwdcache)) {
3923       /* We still may be able to determine pw_uid and pw_gid */
3924       name_desc.dsc$w_length=  strlen(name);
3925       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
3926       name_desc.dsc$b_class=   DSC$K_CLASS_S;
3927       name_desc.dsc$a_pointer= (char *) name;
3928       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3929         __pwdcache.pw_uid= uic.uic$l_uic;
3930         __pwdcache.pw_gid= uic.uic$v_group;
3931       }
3932       else {
3933         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3934           set_vaxc_errno(sts);
3935           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3936           return NULL;
3937         }
3938         else { _ckvmssts(sts); }
3939       }
3940     }
3941     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3942     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3943     __pwdcache.pw_name= __pw_namecache;
3944     return &__pwdcache;
3945 }  /* end of my_getpwnam() */
3946 /*}}}*/
3947
3948 /*
3949  * Get information for a particular UIC or UID.
3950  * Called by my_getpwent with uid=-1 to list all users.
3951 */
3952 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3953 struct passwd *my_getpwuid(Uid_t uid)
3954 {
3955     const $DESCRIPTOR(name_desc,__pw_namecache);
3956     unsigned short lname;
3957     union uicdef uic;
3958     unsigned long int status;
3959     dTHX;
3960
3961     if (uid == (unsigned int) -1) {
3962       do {
3963         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3964         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3965           set_vaxc_errno(status);
3966           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3967           my_endpwent();
3968           return NULL;
3969         }
3970         else { _ckvmssts(status); }
3971       } while (!valid_uic (uic));
3972     }
3973     else {
3974       uic.uic$l_uic= uid;
3975       if (!uic.uic$v_group)
3976         uic.uic$v_group= PerlProc_getgid();
3977       if (valid_uic(uic))
3978         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3979       else status = SS$_IVIDENT;
3980       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3981           status == RMS$_PRV) {
3982         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3983         return NULL;
3984       }
3985       else { _ckvmssts(status); }
3986     }
3987     __pw_namecache[lname]= '\0';
3988     __mystrtolower(__pw_namecache);
3989
3990     __pwdcache = __passwd_empty;
3991     __pwdcache.pw_name = __pw_namecache;
3992
3993 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3994     The identifier's value is usually the UIC, but it doesn't have to be,
3995     so if we can, we let fillpasswd update this. */
3996     __pwdcache.pw_uid =  uic.uic$l_uic;
3997     __pwdcache.pw_gid =  uic.uic$v_group;
3998
3999     fillpasswd(__pw_namecache, &__pwdcache);
4000     return &__pwdcache;
4001
4002 }  /* end of my_getpwuid() */
4003 /*}}}*/
4004
4005 /*
4006  * Get information for next user.
4007 */
4008 /*{{{struct passwd *my_getpwent()*/
4009 struct passwd *my_getpwent()
4010 {
4011     return (my_getpwuid((unsigned int) -1));
4012 }
4013 /*}}}*/
4014
4015 /*
4016  * Finish searching rights database for users.
4017 */
4018 /*{{{void my_endpwent()*/
4019 void my_endpwent()
4020 {
4021     dTHX;
4022     if (contxt) {
4023       _ckvmssts(sys$finish_rdb(&contxt));
4024       contxt= 0;
4025     }
4026 }
4027 /*}}}*/
4028
4029 #ifdef HOMEGROWN_POSIX_SIGNALS
4030   /* Signal handling routines, pulled into the core from POSIX.xs.
4031    *
4032    * We need these for threads, so they've been rolled into the core,
4033    * rather than left in POSIX.xs.
4034    *
4035    * (DRS, Oct 23, 1997)
4036    */
4037
4038   /* sigset_t is atomic under VMS, so these routines are easy */
4039 /*{{{int my_sigemptyset(sigset_t *) */
4040 int my_sigemptyset(sigset_t *set) {
4041     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4042     *set = 0; return 0;
4043 }
4044 /*}}}*/
4045
4046
4047 /*{{{int my_sigfillset(sigset_t *)*/
4048 int my_sigfillset(sigset_t *set) {
4049     int i;
4050     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4051     for (i = 0; i < NSIG; i++) *set |= (1 << i);
4052     return 0;
4053 }
4054 /*}}}*/
4055
4056
4057 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4058 int my_sigaddset(sigset_t *set, int sig) {
4059     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4060     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4061     *set |= (1 << (sig - 1));
4062     return 0;
4063 }
4064 /*}}}*/
4065
4066
4067 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4068 int my_sigdelset(sigset_t *set, int sig) {
4069     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4070     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4071     *set &= ~(1 << (sig - 1));
4072     return 0;
4073 }
4074 /*}}}*/
4075
4076
4077 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4078 int my_sigismember(sigset_t *set, int sig) {
4079     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4080     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4081     *set & (1 << (sig - 1));
4082 }
4083 /*}}}*/
4084
4085
4086 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4087 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4088     sigset_t tempmask;
4089
4090     /* If set and oset are both null, then things are badly wrong. Bail out. */
4091     if ((oset == NULL) && (set == NULL)) {
4092       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4093       return -1;
4094     }
4095
4096     /* If set's null, then we're just handling a fetch. */
4097     if (set == NULL) {
4098         tempmask = sigblock(0);
4099     }
4100     else {
4101       switch (how) {
4102       case SIG_SETMASK:
4103         tempmask = sigsetmask(*set);
4104         break;
4105       case SIG_BLOCK:
4106         tempmask = sigblock(*set);
4107         break;
4108       case SIG_UNBLOCK:
4109         tempmask = sigblock(0);
4110         sigsetmask(*oset & ~tempmask);
4111         break;
4112       default:
4113         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4114         return -1;
4115       }
4116     }
4117
4118     /* Did they pass us an oset? If so, stick our holding mask into it */
4119     if (oset)
4120       *oset = tempmask;
4121
4122     return 0;
4123 }
4124 /*}}}*/
4125 #endif  /* HOMEGROWN_POSIX_SIGNALS */
4126
4127
4128 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4129  * my_utime(), and flex_stat(), all of which operate on UTC unless
4130  * VMSISH_TIMES is true.
4131  */
4132 /* method used to handle UTC conversions:
4133  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
4134  */
4135 static int gmtime_emulation_type;
4136 /* number of secs to add to UTC POSIX-style time to get local time */
4137 static long int utc_offset_secs;
4138
4139 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4140  * in vmsish.h.  #undef them here so we can call the CRTL routines
4141  * directly.
4142  */
4143 #undef gmtime
4144 #undef localtime
4145 #undef time
4146
4147 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4148 #  define RTL_USES_UTC 1
4149 #endif
4150
4151 /*
4152  * DEC C previous to 6.0 corrupts the behavior of the /prefix
4153  * qualifier with the extern prefix pragma.  This provisional
4154  * hack circumvents this prefix pragma problem in previous
4155  * precompilers.
4156  */
4157 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4158 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4159 #    pragma __extern_prefix save
4160 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
4161 #    define gmtime decc$__utctz_gmtime
4162 #    define localtime decc$__utctz_localtime
4163 #    define time decc$__utc_time
4164 #    pragma __extern_prefix restore
4165
4166      struct tm *gmtime(), *localtime();
4167
4168 #  endif
4169 #endif
4170
4171
4172 static time_t toutc_dst(time_t loc) {
4173   struct tm *rsltmp;
4174
4175   if ((rsltmp = localtime(&loc)) == NULL) return -1;
4176   loc -= utc_offset_secs;
4177   if (rsltmp->tm_isdst) loc -= 3600;
4178   return loc;
4179 }
4180 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4181        ((gmtime_emulation_type || my_time(NULL)), \
4182        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4183        ((secs) - utc_offset_secs))))
4184
4185 static time_t toloc_dst(time_t utc) {
4186   struct tm *rsltmp;
4187
4188   utc += utc_offset_secs;
4189   if ((rsltmp = localtime(&utc)) == NULL) return -1;
4190   if (rsltmp->tm_isdst) utc += 3600;
4191   return utc;
4192 }
4193 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
4194        ((gmtime_emulation_type || my_time(NULL)), \
4195        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4196        ((secs) + utc_offset_secs))))
4197
4198
4199 /* my_time(), my_localtime(), my_gmtime()
4200  * By default traffic in UTC time values, using CRTL gmtime() or
4201  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4202  * Note: We need to use these functions even when the CRTL has working
4203  * UTC support, since they also handle C<use vmsish qw(times);>
4204  *
4205  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
4206  * Modified by Charles Bailey <bailey@newman.upenn.edu>
4207  */
4208
4209 /*{{{time_t my_time(time_t *timep)*/
4210 time_t my_time(time_t *timep)
4211 {
4212   dTHX;
4213   time_t when;
4214   struct tm *tm_p;
4215
4216   if (gmtime_emulation_type == 0) {
4217     int dstnow;
4218     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
4219                               /* results of calls to gmtime() and localtime() */
4220                               /* for same &base */
4221
4222     gmtime_emulation_type++;
4223     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4224       char off[LNM$C_NAMLENGTH+1];;
4225
4226       gmtime_emulation_type++;
4227       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4228         gmtime_emulation_type++;
4229         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4230       }
4231       else { utc_offset_secs = atol(off); }
4232     }
4233     else { /* We've got a working gmtime() */
4234       struct tm gmt, local;
4235
4236       gmt = *tm_p;
4237       tm_p = localtime(&base);
4238       local = *tm_p;
4239       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
4240       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4241       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
4242       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
4243     }
4244   }
4245
4246   when = time(NULL);
4247 # ifdef VMSISH_TIME
4248 # ifdef RTL_USES_UTC
4249   if (VMSISH_TIME) when = _toloc(when);
4250 # else
4251   if (!VMSISH_TIME) when = _toutc(when);
4252 # endif
4253 # endif
4254   if (timep != NULL) *timep = when;
4255   return when;
4256
4257 }  /* end of my_time() */
4258 /*}}}*/
4259
4260
4261 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4262 struct tm *
4263 my_gmtime(const time_t *timep)
4264 {
4265   dTHX;
4266   char *p;
4267   time_t when;
4268   struct tm *rsltmp;
4269
4270   if (timep == NULL) {
4271     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4272     return NULL;
4273   }
4274   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4275
4276   when = *timep;
4277 # ifdef VMSISH_TIME
4278   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4279 #  endif
4280 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
4281   return gmtime(&when);
4282 # else
4283   /* CRTL localtime() wants local time as input, so does no tz correction */
4284   rsltmp = localtime(&when);
4285   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
4286   return rsltmp;
4287 #endif
4288 }  /* end of my_gmtime() */
4289 /*}}}*/
4290
4291
4292 /*{{{struct tm *my_localtime(const time_t *timep)*/
4293 struct tm *
4294 my_localtime(const time_t *timep)
4295 {
4296   dTHX;
4297   time_t when;
4298   struct tm *rsltmp;
4299
4300   if (timep == NULL) {
4301     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4302     return NULL;
4303   }
4304   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
4305   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4306
4307   when = *timep;
4308 # ifdef RTL_USES_UTC
4309 # ifdef VMSISH_TIME
4310   if (VMSISH_TIME) when = _toutc(when);
4311 # endif
4312   /* CRTL localtime() wants UTC as input, does tz correction itself */
4313   return localtime(&when);
4314 # else
4315 # ifdef VMSISH_TIME
4316   if (!VMSISH_TIME) when = _toloc(when);   /*  Input was UTC */
4317 # endif
4318 # endif
4319   /* CRTL localtime() wants local time as input, so does no tz correction */
4320   rsltmp = localtime(&when);
4321   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4322   return rsltmp;
4323
4324 } /*  end of my_localtime() */
4325 /*}}}*/
4326
4327 /* Reset definitions for later calls */
4328 #define gmtime(t)    my_gmtime(t)
4329 #define localtime(t) my_localtime(t)
4330 #define time(t)      my_time(t)
4331
4332
4333 /* my_utime - update modification time of a file
4334  * calling sequence is identical to POSIX utime(), but under
4335  * VMS only the modification time is changed; ODS-2 does not
4336  * maintain access times.  Restrictions differ from the POSIX
4337  * definition in that the time can be changed as long as the
4338  * caller has permission to execute the necessary IO$_MODIFY $QIO;
4339  * no separate checks are made to insure that the caller is the
4340  * owner of the file or has special privs enabled.
4341  * Code here is based on Joe Meadows' FILE utility.
4342  */
4343
4344 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4345  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
4346  * in 100 ns intervals.
4347  */
4348 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4349
4350 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4351 int my_utime(char *file, struct utimbuf *utimes)
4352 {
4353   dTHX;
4354   register int i;
4355   long int bintime[2], len = 2, lowbit, unixtime,
4356            secscale = 10000000; /* seconds --> 100 ns intervals */
4357   unsigned long int chan, iosb[2], retsts;
4358   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4359   struct FAB myfab = cc$rms_fab;
4360   struct NAM mynam = cc$rms_nam;
4361 #if defined (__DECC) && defined (__VAX)
4362   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4363    * at least through VMS V6.1, which causes a type-conversion warning.
4364    */
4365 #  pragma message save
4366 #  pragma message disable cvtdiftypes
4367 #endif
4368   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4369   struct fibdef myfib;
4370 #if defined (__DECC) && defined (__VAX)
4371   /* This should be right after the declaration of myatr, but due
4372    * to a bug in VAX DEC C, this takes effect a statement early.
4373    */
4374 #  pragma message restore
4375 #endif
4376   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4377                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4378                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4379
4380   if (file == NULL || *file == '\0') {
4381     set_errno(ENOENT);
4382     set_vaxc_errno(LIB$_INVARG);
4383     return -1;
4384   }
4385   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4386
4387   if (utimes != NULL) {
4388     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
4389      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4390      * Since time_t is unsigned long int, and lib$emul takes a signed long int
4391      * as input, we force the sign bit to be clear by shifting unixtime right
4392      * one bit, then multiplying by an extra factor of 2 in lib$emul().
4393      */
4394     lowbit = (utimes->modtime & 1) ? secscale : 0;
4395     unixtime = (long int) utimes->modtime;
4396 #   ifdef VMSISH_TIME
4397     /* If input was UTC; convert to local for sys svc */
4398     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4399 #   endif
4400     unixtime >>= 1;  secscale <<= 1;
4401     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4402     if (!(retsts & 1)) {
4403       set_errno(EVMSERR);
4404       set_vaxc_errno(retsts);
4405       return -1;
4406     }
4407     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4408     if (!(retsts & 1)) {
4409       set_errno(EVMSERR);
4410       set_vaxc_errno(retsts);
4411       return -1;
4412     }
4413   }
4414   else {
4415     /* Just get the current time in VMS format directly */
4416     retsts = sys$gettim(bintime);
4417     if (!(retsts & 1)) {
4418       set_errno(EVMSERR);
4419       set_vaxc_errno(retsts);
4420       return -1;
4421     }
4422   }
4423
4424   myfab.fab$l_fna = vmsspec;
4425   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4426   myfab.fab$l_nam = &mynam;
4427   mynam.nam$l_esa = esa;
4428   mynam.nam$b_ess = (unsigned char) sizeof esa;
4429   mynam.nam$l_rsa = rsa;
4430   mynam.nam$b_rss = (unsigned char) sizeof rsa;
4431
4432   /* Look for the file to be affected, letting RMS parse the file
4433    * specification for us as well.  I have set errno using only
4434    * values documented in the utime() man page for VMS POSIX.
4435    */
4436   retsts = sys$parse(&myfab,0,0);
4437   if (!(retsts & 1)) {
4438     set_vaxc_errno(retsts);
4439     if      (retsts == RMS$_PRV) set_errno(EACCES);
4440     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4441     else                         set_errno(EVMSERR);
4442     return -1;
4443   }
4444   retsts = sys$search(&myfab,0,0);
4445   if (!(retsts & 1)) {
4446     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4447     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4448     set_vaxc_errno(retsts);
4449     if      (retsts == RMS$_PRV) set_errno(EACCES);
4450     else if (retsts == RMS$_FNF) set_errno(ENOENT);
4451     else                         set_errno(EVMSERR);
4452     return -1;
4453   }
4454
4455   devdsc.dsc$w_length = mynam.nam$b_dev;
4456   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4457
4458   retsts = sys$assign(&devdsc,&chan,0,0);
4459   if (!(retsts & 1)) {
4460     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4461     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4462     set_vaxc_errno(retsts);
4463     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
4464     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
4465     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
4466     else                               set_errno(EVMSERR);
4467     return -1;
4468   }
4469
4470   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4471   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4472
4473   memset((void *) &myfib, 0, sizeof myfib);
4474 #ifdef __DECC
4475   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4476   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4477   /* This prevents the revision time of the file being reset to the current
4478    * time as a result of our IO$_MODIFY $QIO. */
4479   myfib.fib$l_acctl = FIB$M_NORECORD;
4480 #else
4481   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4482   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4483   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4484 #endif
4485   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4486   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
4487   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
4488   _ckvmssts(sys$dassgn(chan));
4489   if (retsts & 1) retsts = iosb[0];
4490   if (!(retsts & 1)) {
4491     set_vaxc_errno(retsts);
4492     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4493     else                      set_errno(EVMSERR);
4494     return -1;
4495   }
4496
4497   return 0;
4498 }  /* end of my_utime() */
4499 /*}}}*/
4500
4501 /*
4502  * flex_stat, flex_fstat
4503  * basic stat, but gets it right when asked to stat
4504  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4505  */
4506
4507 /* encode_dev packs a VMS device name string into an integer to allow
4508  * simple comparisons. This can be used, for example, to check whether two
4509  * files are located on the same device, by comparing their encoded device
4510  * names. Even a string comparison would not do, because stat() reuses the
4511  * device name buffer for each call; so without encode_dev, it would be
4512  * necessary to save the buffer and use strcmp (this would mean a number of
4513  * changes to the standard Perl code, to say nothing of what a Perl script
4514  * would have to do.
4515  *
4516  * The device lock id, if it exists, should be unique (unless perhaps compared
4517  * with lock ids transferred from other nodes). We have a lock id if the disk is
4518  * mounted cluster-wide, which is when we tend to get long (host-qualified)
4519  * device names. Thus we use the lock id in preference, and only if that isn't
4520  * available, do we try to pack the device name into an integer (flagged by
4521  * the sign bit (LOCKID_MASK) being set).
4522  *
4523  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4524  * name and its encoded form, but it seems very unlikely that we will find
4525  * two files on different disks that share the same encoded device names,
4526  * and even more remote that they will share the same file id (if the test
4527  * is to check for the same file).
4528  *
4529  * A better method might be to use sys$device_scan on the first call, and to
4530  * search for the device, returning an index into the cached array.
4531  * The number returned would be more intelligable.
4532  * This is probably not worth it, and anyway would take quite a bit longer
4533  * on the first call.
4534  */
4535 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
4536 static mydev_t encode_dev (const char *dev)
4537 {
4538   int i;
4539   unsigned long int f;
4540   mydev_t enc;
4541   char c;
4542   const char *q;
4543   dTHX;
4544
4545   if (!dev || !dev[0]) return 0;
4546
4547 #if LOCKID_MASK
4548   {
4549     struct dsc$descriptor_s dev_desc;
4550     unsigned long int status, lockid, item = DVI$_LOCKID;
4551
4552     /* For cluster-mounted disks, the disk lock identifier is unique, so we
4553        can try that first. */
4554     dev_desc.dsc$w_length =  strlen (dev);
4555     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
4556     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
4557     dev_desc.dsc$a_pointer = (char *) dev;
4558     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4559     if (lockid) return (lockid & ~LOCKID_MASK);
4560   }
4561 #endif
4562
4563   /* Otherwise we try to encode the device name */
4564   enc = 0;
4565   f = 1;
4566   i = 0;
4567   for (q = dev + strlen(dev); q--; q >= dev) {
4568     if (isdigit (*q))
4569       c= (*q) - '0';
4570     else if (isalpha (toupper (*q)))
4571       c= toupper (*q) - 'A' + (char)10;
4572     else
4573       continue; /* Skip '$'s */
4574     i++;
4575     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
4576     if (i>1) f *= 36;
4577     enc += f * (unsigned long int) c;
4578   }
4579   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
4580
4581 }  /* end of encode_dev() */
4582
4583 static char namecache[NAM$C_MAXRSS+1];
4584
4585 static int
4586 is_null_device(name)
4587     const char *name;
4588 {
4589     dTHX;
4590     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4591        The underscore prefix, controller letter, and unit number are
4592        independently optional; for our purposes, the colon punctuation
4593        is not.  The colon can be trailed by optional directory and/or
4594        filename, but two consecutive colons indicates a nodename rather
4595        than a device.  [pr]  */
4596   if (*name == '_') ++name;
4597   if (tolower(*name++) != 'n') return 0;
4598   if (tolower(*name++) != 'l') return 0;
4599   if (tolower(*name) == 'a') ++name;
4600   if (*name == '0') ++name;
4601   return (*name++ == ':') && (*name != ':');
4602 }
4603
4604 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
4605 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4606  * subset of the applicable information.
4607  */
4608 bool
4609 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4610 {
4611   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4612   else {
4613     char fname[NAM$C_MAXRSS+1];
4614     unsigned long int retsts;
4615     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4616                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4617
4618     /* If the struct mystat is stale, we're OOL; stat() overwrites the
4619        device name on successive calls */
4620     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4621     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4622     namdsc.dsc$a_pointer = fname;
4623     namdsc.dsc$w_length = sizeof fname - 1;
4624
4625     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4626                              &namdsc,&namdsc.dsc$w_length,0,0);
4627     if (retsts & 1) {
4628       fname[namdsc.dsc$w_length] = '\0';
4629       return cando_by_name(bit,effective,fname);
4630     }
4631     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4632       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4633       return FALSE;
4634     }
4635     _ckvmssts(retsts);
4636     return FALSE;  /* Should never get to here */
4637   }
4638 }  /* end of cando() */
4639 /*}}}*/
4640
4641
4642 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4643 I32
4644 cando_by_name(I32 bit, Uid_t effective, char *fname)
4645 {
4646   static char usrname[L_cuserid];
4647   static struct dsc$descriptor_s usrdsc =
4648          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4649   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4650   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4651   unsigned short int retlen;
4652   dTHX;
4653   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4654   union prvdef curprv;
4655   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4656          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4657   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4658          {0,0,0,0}};
4659
4660   if (!fname || !*fname) return FALSE;
4661   /* Make sure we expand logical names, since sys$check_access doesn't */
4662   if (!strpbrk(fname,"/]>:")) {
4663     strcpy(fileified,fname);
4664     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4665     fname = fileified;
4666   }
4667   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4668   retlen = namdsc.dsc$w_length = strlen(vmsname);
4669   namdsc.dsc$a_pointer = vmsname;
4670   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4671       vmsname[retlen-1] == ':') {
4672     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4673     namdsc.dsc$w_length = strlen(fileified);
4674     namdsc.dsc$a_pointer = fileified;
4675   }
4676
4677   if (!usrdsc.dsc$w_length) {
4678     cuserid(usrname);
4679     usrdsc.dsc$w_length = strlen(usrname);
4680   }
4681
4682   switch (bit) {
4683     case S_IXUSR: case S_IXGRP: case S_IXOTH:
4684       access = ARM$M_EXECUTE; break;
4685     case S_IRUSR: case S_IRGRP: case S_IROTH:
4686       access = ARM$M_READ; break;
4687     case S_IWUSR: case S_IWGRP: case S_IWOTH:
4688       access = ARM$M_WRITE; break;
4689     case S_IDUSR: case S_IDGRP: case S_IDOTH:
4690       access = ARM$M_DELETE; break;
4691     default:
4692       return FALSE;
4693   }
4694
4695   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4696   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
4697       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4698       retsts == RMS$_DIR        || retsts == RMS$_DEV) {
4699     set_vaxc_errno(retsts);
4700     if (retsts == SS$_NOPRIV) set_errno(EACCES);
4701     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4702     else set_errno(ENOENT);
4703     return FALSE;
4704   }
4705   if (retsts == SS$_NORMAL) {
4706     if (!privused) return TRUE;
4707     /* We can get access, but only by using privs.  Do we have the
4708        necessary privs currently enabled? */
4709     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4710     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
4711     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
4712                                       !curprv.prv$v_bypass)  return FALSE;
4713     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
4714          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
4715     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4716     return TRUE;
4717   }
4718   if (retsts == SS$_ACCONFLICT) {
4719     return TRUE;
4720   }
4721
4722 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 &&  defined(__DECC_VER) && __DECC_VER == 6009001
4723   /* XXX Hideous kluge to accomodate error in specific version of RTL;
4724      we hope it'll be buried soon */
4725   if (retsts == 114762) return TRUE;
4726 #endif
4727   _ckvmssts(retsts);
4728
4729   return FALSE;  /* Should never get here */
4730
4731 }  /* end of cando_by_name() */
4732 /*}}}*/
4733
4734
4735 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4736 int
4737 flex_fstat(int fd, Stat_t *statbufp)
4738 {
4739   dTHX;
4740   if (!fstat(fd,(stat_t *) statbufp)) {
4741     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4742     statbufp->st_dev = encode_dev(statbufp->st_devnam);
4743 #   ifdef RTL_USES_UTC
4744 #   ifdef VMSISH_TIME
4745     if (VMSISH_TIME) {
4746       statbufp->st_mtime = _toloc(statbufp->st_mtime);
4747       statbufp->st_atime = _toloc(statbufp->st_atime);
4748       statbufp->st_ctime = _toloc(statbufp->st_ctime);
4749     }
4750 #   endif
4751 #   else
4752 #   ifdef VMSISH_TIME
4753     if (!VMSISH_TIME) { /* Return UTC instead of local time */
4754 #   else
4755     if (1) {
4756 #   endif
4757       statbufp->st_mtime = _toutc(statbufp->st_mtime);
4758       statbufp->st_atime = _toutc(statbufp->st_atime);
4759       statbufp->st_ctime = _toutc(statbufp->st_ctime);
4760     }
4761 #endif
4762     return 0;
4763   }
4764   return -1;
4765
4766 }  /* end of flex_fstat() */
4767 /*}}}*/
4768
4769 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4770 int
4771 flex_stat(const char *fspec, Stat_t *statbufp)
4772 {
4773     dTHX;
4774     char fileified[NAM$C_MAXRSS+1];
4775     char temp_fspec[NAM$C_MAXRSS+300];
4776     int retval = -1;
4777
4778     strcpy(temp_fspec, fspec);
4779     if (statbufp == (Stat_t *) &PL_statcache)
4780       do_tovmsspec(temp_fspec,namecache,0);
4781     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4782       memset(statbufp,0,sizeof *statbufp);
4783       statbufp->st_dev = encode_dev("_NLA0:");
4784       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4785       statbufp->st_uid = 0x00010001;
4786       statbufp->st_gid = 0x0001;
4787       time((time_t *)&statbufp->st_mtime);
4788       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4789       return 0;
4790     }
4791
4792     /* Try for a directory name first.  If fspec contains a filename without
4793      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4794      * and sea:[wine.dark]water. exist, we prefer the directory here.
4795      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4796      * not sea:[wine.dark]., if the latter exists.  If the intended target is
4797      * the file with null type, specify this by calling flex_stat() with
4798      * a '.' at the end of fspec.
4799      */
4800     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4801       retval = stat(fileified,(stat_t *) statbufp);
4802       if (!retval && statbufp == (Stat_t *) &PL_statcache)
4803         strcpy(namecache,fileified);
4804     }
4805     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4806     if (!retval) {
4807       statbufp->st_dev = encode_dev(statbufp->st_devnam);
4808 #     ifdef RTL_USES_UTC
4809 #     ifdef VMSISH_TIME
4810       if (VMSISH_TIME) {
4811         statbufp->st_mtime = _toloc(statbufp->st_mtime);
4812         statbufp->st_atime = _toloc(statbufp->st_atime);
4813         statbufp->st_ctime = _toloc(statbufp->st_ctime);
4814       }
4815 #     endif
4816 #     else
4817 #     ifdef VMSISH_TIME
4818       if (!VMSISH_TIME) { /* Return UTC instead of local time */
4819 #     else
4820       if (1) {
4821 #     endif
4822         statbufp->st_mtime = _toutc(statbufp->st_mtime);
4823         statbufp->st_atime = _toutc(statbufp->st_atime);
4824         statbufp->st_ctime = _toutc(statbufp->st_ctime);
4825       }
4826 #     endif
4827     }
4828     return retval;
4829
4830 }  /* end of flex_stat() */
4831 /*}}}*/
4832
4833
4834 /*{{{char *my_getlogin()*/
4835 /* VMS cuserid == Unix getlogin, except calling sequence */
4836 char *
4837 my_getlogin()
4838 {
4839     static char user[L_cuserid];
4840     return cuserid(user);
4841 }
4842 /*}}}*/
4843
4844
4845 /*  rmscopy - copy a file using VMS RMS routines
4846  *
4847  *  Copies contents and attributes of spec_in to spec_out, except owner
4848  *  and protection information.  Name and type of spec_in are used as
4849  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
4850  *  should try to propagate timestamps from the input file to the output file.
4851  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
4852  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
4853  *  propagated to the output file at creation iff the output file specification
4854  *  did not contain an explicit name or type, and the revision date is always
4855  *  updated at the end of the copy operation.  If it is greater than 0, then
4856  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4857  *  other than the revision date should be propagated, and bit 1 indicates
4858  *  that the revision date should be propagated.
4859  *
4860  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4861  *
4862  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4863  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
4864  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
4865  * as part of the Perl standard distribution under the terms of the
4866  * GNU General Public License or the Perl Artistic License.  Copies
4867  * of each may be found in the Perl standard distribution.
4868  */
4869 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4870 int
4871 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
4872 {
4873     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4874          rsa[NAM$C_MAXRSS], ubf[32256];
4875     unsigned long int i, sts, sts2;
4876     struct FAB fab_in, fab_out;
4877     struct RAB rab_in, rab_out;
4878     struct NAM nam;
4879     struct XABDAT xabdat;
4880     struct XABFHC xabfhc;
4881     struct XABRDT xabrdt;
4882     struct XABSUM xabsum;
4883
4884     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
4885         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4886       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4887       return 0;
4888     }
4889
4890     fab_in = cc$rms_fab;
4891     fab_in.fab$l_fna = vmsin;
4892     fab_in.fab$b_fns = strlen(vmsin);
4893     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4894     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4895     fab_in.fab$l_fop = FAB$M_SQO;
4896     fab_in.fab$l_nam =  &nam;
4897     fab_in.fab$l_xab = (void *) &xabdat;
4898
4899     nam = cc$rms_nam;
4900     nam.nam$l_rsa = rsa;
4901     nam.nam$b_rss = sizeof(rsa);
4902     nam.nam$l_esa = esa;
4903     nam.nam$b_ess = sizeof (esa);
4904     nam.nam$b_esl = nam.nam$b_rsl = 0;
4905
4906     xabdat = cc$rms_xabdat;        /* To get creation date */
4907     xabdat.xab$l_nxt = (void *) &xabfhc;
4908
4909     xabfhc = cc$rms_xabfhc;        /* To get record length */
4910     xabfhc.xab$l_nxt = (void *) &xabsum;
4911
4912     xabsum = cc$rms_xabsum;        /* To get key and area information */
4913
4914     if (!((sts = sys$open(&fab_in)) & 1)) {
4915       set_vaxc_errno(sts);
4916       switch (sts) {
4917         case RMS$_FNF: case RMS$_DNF:
4918           set_errno(ENOENT); break;
4919         case RMS$_DIR:
4920           set_errno(ENOTDIR); break;
4921         case RMS$_DEV:
4922           set_errno(ENODEV); break;
4923         case RMS$_SYN:
4924           set_errno(EINVAL); break;
4925         case RMS$_PRV:
4926           set_errno(EACCES); break;
4927         default:
4928           set_errno(EVMSERR);
4929       }
4930       return 0;
4931     }
4932
4933     fab_out = fab_in;
4934     fab_out.fab$w_ifi = 0;
4935     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4936     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4937     fab_out.fab$l_fop = FAB$M_SQO;
4938     fab_out.fab$l_fna = vmsout;
4939     fab_out.fab$b_fns = strlen(vmsout);
4940     fab_out.fab$l_dna = nam.nam$l_name;
4941     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4942
4943     if (preserve_dates == 0) {  /* Act like DCL COPY */
4944       nam.nam$b_nop = NAM$M_SYNCHK;
4945       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
4946       if (!((sts = sys$parse(&fab_out)) & 1)) {
4947         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4948         set_vaxc_errno(sts);
4949         return 0;
4950       }
4951       fab_out.fab$l_xab = (void *) &xabdat;
4952       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4953     }
4954     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
4955     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
4956       preserve_dates =0;      /* bitmask from this point forward   */
4957
4958     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4959     if (!((sts = sys$create(&fab_out)) & 1)) {
4960       set_vaxc_errno(sts);
4961       switch (sts) {
4962         case RMS$_DNF:
4963           set_errno(ENOENT); break;
4964         case RMS$_DIR:
4965           set_errno(ENOTDIR); break;
4966         case RMS$_DEV:
4967           set_errno(ENODEV); break;
4968         case RMS$_SYN:
4969           set_errno(EINVAL); break;
4970         case RMS$_PRV:
4971           set_errno(EACCES); break;
4972         default:
4973           set_errno(EVMSERR);
4974       }
4975       return 0;
4976     }
4977     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
4978     if (preserve_dates & 2) {
4979       /* sys$close() will process xabrdt, not xabdat */
4980       xabrdt = cc$rms_xabrdt;
4981 #ifndef __GNUC__
4982       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4983 #else
4984       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4985        * is unsigned long[2], while DECC & VAXC use a struct */
4986       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4987 #endif
4988       fab_out.fab$l_xab = (void *) &xabrdt;
4989     }
4990
4991     rab_in = cc$rms_rab;
4992     rab_in.rab$l_fab = &fab_in;
4993     rab_in.rab$l_rop = RAB$M_BIO;
4994     rab_in.rab$l_ubf = ubf;
4995     rab_in.rab$w_usz = sizeof ubf;
4996     if (!((sts = sys$connect(&rab_in)) & 1)) {
4997       sys$close(&fab_in); sys$close(&fab_out);
4998       set_errno(EVMSERR); set_vaxc_errno(sts);
4999       return 0;
5000     }
5001
5002     rab_out = cc$rms_rab;
5003     rab_out.rab$l_fab = &fab_out;
5004     rab_out.rab$l_rbf = ubf;
5005     if (!((sts = sys$connect(&rab_out)) & 1)) {
5006       sys$close(&fab_in); sys$close(&fab_out);
5007       set_errno(EVMSERR); set_vaxc_errno(sts);
5008       return 0;
5009     }
5010
5011     while ((sts = sys$read(&rab_in))) {  /* always true  */
5012       if (sts == RMS$_EOF) break;
5013       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
5014       if (!(sts & 1) || !((sts = sys$write(&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
5021     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
5022     sys$close(&fab_in);  sys$close(&fab_out);
5023     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5024     if (!(sts & 1)) {
5025       set_errno(EVMSERR); set_vaxc_errno(sts);
5026       return 0;
5027     }
5028
5029     return 1;
5030
5031 }  /* end of rmscopy() */
5032 /*}}}*/
5033
5034
5035 /***  The following glue provides 'hooks' to make some of the routines
5036  * from this file available from Perl.  These routines are sufficiently
5037  * basic, and are required sufficiently early in the build process,
5038  * that's it's nice to have them available to miniperl as well as the
5039  * full Perl, so they're set up here instead of in an extension.  The
5040  * Perl code which handles importation of these names into a given
5041  * package lives in [.VMS]Filespec.pm in @INC.
5042  */
5043
5044 void
5045 rmsexpand_fromperl(pTHX_ CV *cv)
5046 {
5047   dXSARGS;
5048   char *fspec, *defspec = NULL, *rslt;
5049   STRLEN n_a;
5050
5051   if (!items || items > 2)
5052     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5053   fspec = SvPV(ST(0),n_a);
5054   if (!fspec || !*fspec) XSRETURN_UNDEF;
5055   if (items == 2) defspec = SvPV(ST(1),n_a);
5056
5057   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5058   ST(0) = sv_newmortal();
5059   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5060   XSRETURN(1);
5061 }
5062
5063 void
5064 vmsify_fromperl(pTHX_ CV *cv)
5065 {
5066   dXSARGS;
5067   char *vmsified;
5068   STRLEN n_a;
5069
5070   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5071   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5072   ST(0) = sv_newmortal();
5073   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5074   XSRETURN(1);
5075 }
5076
5077 void
5078 unixify_fromperl(pTHX_ CV *cv)
5079 {
5080   dXSARGS;
5081   char *unixified;
5082   STRLEN n_a;
5083
5084   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5085   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5086   ST(0) = sv_newmortal();
5087   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5088   XSRETURN(1);
5089 }
5090
5091 void
5092 fileify_fromperl(pTHX_ CV *cv)
5093 {
5094   dXSARGS;
5095   char *fileified;
5096   STRLEN n_a;
5097
5098   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5099   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5100   ST(0) = sv_newmortal();
5101   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5102   XSRETURN(1);
5103 }
5104
5105 void
5106 pathify_fromperl(pTHX_ CV *cv)
5107 {
5108   dXSARGS;
5109   char *pathified;
5110   STRLEN n_a;
5111
5112   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5113   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5114   ST(0) = sv_newmortal();
5115   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5116   XSRETURN(1);
5117 }
5118
5119 void
5120 vmspath_fromperl(pTHX_ CV *cv)
5121 {
5122   dXSARGS;
5123   char *vmspath;
5124   STRLEN n_a;
5125
5126   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5127   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5128   ST(0) = sv_newmortal();
5129   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5130   XSRETURN(1);
5131 }
5132
5133 void
5134 unixpath_fromperl(pTHX_ CV *cv)
5135 {
5136   dXSARGS;
5137   char *unixpath;
5138   STRLEN n_a;
5139
5140   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5141   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5142   ST(0) = sv_newmortal();
5143   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5144   XSRETURN(1);
5145 }
5146
5147 void
5148 candelete_fromperl(pTHX_ CV *cv)
5149 {
5150   dXSARGS;
5151   char fspec[NAM$C_MAXRSS+1], *fsp;
5152   SV *mysv;
5153   IO *io;
5154   STRLEN n_a;
5155
5156   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5157
5158   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5159   if (SvTYPE(mysv) == SVt_PVGV) {
5160     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5161       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5162       ST(0) = &PL_sv_no;
5163       XSRETURN(1);
5164     }
5165     fsp = fspec;
5166   }
5167   else {
5168     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5169       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5170       ST(0) = &PL_sv_no;
5171       XSRETURN(1);
5172     }
5173   }
5174
5175   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5176   XSRETURN(1);
5177 }
5178
5179 void
5180 rmscopy_fromperl(pTHX_ CV *cv)
5181 {
5182   dXSARGS;
5183   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5184   int date_flag;
5185   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5186                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5187   unsigned long int sts;
5188   SV *mysv;
5189   IO *io;
5190   STRLEN n_a;
5191
5192   if (items < 2 || items > 3)
5193     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5194
5195   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5196   if (SvTYPE(mysv) == SVt_PVGV) {
5197     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5198       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5199       ST(0) = &PL_sv_no;
5200       XSRETURN(1);
5201     }
5202     inp = inspec;
5203   }
5204   else {
5205     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5206       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5207       ST(0) = &PL_sv_no;
5208       XSRETURN(1);
5209     }
5210   }
5211   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5212   if (SvTYPE(mysv) == SVt_PVGV) {
5213     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5214       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5215       ST(0) = &PL_sv_no;
5216       XSRETURN(1);
5217     }
5218     outp = outspec;
5219   }
5220   else {
5221     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5222       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5223       ST(0) = &PL_sv_no;
5224       XSRETURN(1);
5225     }
5226   }
5227   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5228
5229   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5230   XSRETURN(1);
5231 }
5232
5233
5234 void
5235 mod2fname(CV *cv)
5236 {
5237   dXSARGS;
5238   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
5239        workbuff[NAM$C_MAXRSS*1 + 1];
5240   int total_namelen = 3, counter, num_entries;
5241   /* ODS-5 ups this, but we want to be consistent, so... */
5242   int max_name_len = 39;
5243   AV *in_array = (AV *)SvRV(ST(0));
5244
5245   num_entries = av_len(in_array);
5246
5247   /* All the names start with PL_. */
5248   strcpy(ultimate_name, "PL_");
5249
5250   /* Clean up our working buffer */
5251   Zero(work_name, sizeof(work_name), char);
5252
5253   /* Run through the entries and build up a working name */
5254   for(counter = 0; counter <= num_entries; counter++) {
5255     /* If it's not the first name then tack on a __ */
5256     if (counter) {
5257       strcat(work_name, "__");
5258     }
5259     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
5260                            PL_na));
5261   }
5262
5263   /* Check to see if we actually have to bother...*/
5264   if (strlen(work_name) + 3 <= max_name_len) {
5265     strcat(ultimate_name, work_name);
5266   } else {
5267     /* It's too darned big, so we need to go strip. We use the same */
5268     /* algorithm as xsubpp does. First, strip out doubled __ */
5269     char *source, *dest, last;
5270     dest = workbuff;
5271     last = 0;
5272     for (source = work_name; *source; source++) {
5273       if (last == *source && last == '_') {
5274         continue;
5275       }
5276       *dest++ = *source;
5277       last = *source;
5278     }
5279     /* Go put it back */
5280     strcpy(work_name, workbuff);
5281     /* Is it still too big? */
5282     if (strlen(work_name) + 3 > max_name_len) {
5283       /* Strip duplicate letters */
5284       last = 0;
5285       dest = workbuff;
5286       for (source = work_name; *source; source++) {
5287         if (last == toupper(*source)) {
5288         continue;
5289         }
5290         *dest++ = *source;
5291         last = toupper(*source);
5292       }
5293       strcpy(work_name, workbuff);
5294     }
5295
5296     /* Is it *still* too big? */
5297     if (strlen(work_name) + 3 > max_name_len) {
5298       /* Too bad, we truncate */
5299       work_name[max_name_len - 2] = 0;
5300     }
5301     strcat(ultimate_name, work_name);
5302   }
5303
5304   /* Okay, return it */
5305   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
5306   XSRETURN(1);
5307 }
5308
5309 void
5310 init_os_extras()
5311 {
5312   char* file = __FILE__;
5313   dTHX;
5314   char temp_buff[512];
5315   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5316     no_translate_barewords = TRUE;
5317   } else {
5318     no_translate_barewords = FALSE;
5319   }
5320
5321   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5322   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5323   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5324   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5325   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5326   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5327   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5328   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5329   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
5330   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
5331
5332   return;
5333 }
5334
5335 /*  End of vms.c */