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