vms/vms.c

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