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