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