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