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