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