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