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