vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  *
   5  * Last revised: 22-Nov-1995 by Charles Bailey  bailey@genetics.upenn.edu
   6  * Version: 5.2.0
   7  */
   8
   9 #include <acedef.h>
  10 #include <acldef.h>
  11 #include <armdef.h>
  12 #include <atrdef.h>
  13 #include <chpdef.h>
  14 #include <descrip.h>
  15 #include <dvidef.h>
  16 #include <fibdef.h>
  17 #include <float.h>
  18 #include <fscndef.h>
  19 #include <iodef.h>
  20 #include <jpidef.h>
  21 #include <libdef.h>
  22 #include <lib$routines.h>
  23 #include <lnmdef.h>
  24 #include <prvdef.h>
  25 #include <psldef.h>
  26 #include <rms.h>
  27 #include <shrdef.h>
  28 #include <ssdef.h>
  29 #include <starlet.h>
  30 #include <stsdef.h>
  31 #include <syidef.h>
  32 #include <uaidef.h>
  33 #include <uicdef.h>
  34
  35 #include "EXTERN.h"
  36 #include "perl.h"
  37 #include "XSUB.h"
  38
  39 struct itmlst_3 {
  40   unsigned short int buflen;
  41   unsigned short int itmcode;
  42   void *bufadr;
  43   unsigned short int *retlen;
  44 };
  45
  46 static char *
  47 my_trnlnm(char *lnm, char *eqv)
  48 {
  49     static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
  50     unsigned short int eqvlen;
  51     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
  52     $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
  53     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  54     struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
  55                                  {0, 0, 0, 0}};
  56
  57     if (!eqv) eqv = __my_trnlnm_eqv;
  58     lnmlst[0].bufadr = (void *)eqv;
  59     lnmdsc.dsc$a_pointer = lnm;
  60     lnmdsc.dsc$w_length = strlen(lnm);
  61     retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
  62     if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
  63     else if (retsts & 1) {
  64       eqv[eqvlen] = '\0';
  65       return eqv;
  66     }
  67     _ckvmssts(retsts);  /* Must be an error */
  68     return Nullch;      /* Not reached, assuming _ckvmssts() bails out */
  69 }
  70
  71 /* my_getenv
  72  * Translate a logical name.  Substitute for CRTL getenv() to avoid
  73  * memory leak, and to keep my_getenv() and my_setenv() in the same
  74  * domain (mostly - my_getenv() need not return a translation from
  75  * the process logical name table)
  76  *
  77  * Note: Uses static buffer -- not thread-safe!
  78  */
  79 /*{{{ char *my_getenv(char *lnm)*/
  80 char *
  81 my_getenv(char *lnm)
  82 {
  83     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
  84     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
  85
  86     for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
  87     *cp2 = '\0';
  88     if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
  89       getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
  90       return __my_getenv_eqv;
  91     }
  92     else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
  93       return __my_getenv_eqv;
  94     }
  95     else {
  96       unsigned long int retsts;
  97       struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
  98                               valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
  99                                         DSC$K_CLASS_S, __my_getenv_eqv};
 100       symdsc.dsc$w_length = cp1 - lnm;
 101       symdsc.dsc$a_pointer = uplnm;
 102       retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
 103       if (retsts == LIB$_INVSYMNAM) return Nullch;
 104       if (retsts != LIB$_NOSUCHSYM) {
 105         /* We want to return only logical names or CRTL Unix emulations */
 106         if (retsts & 1) return Nullch;
 107         _ckvmssts(retsts);
 108       }
 109       else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
 110     }
 111     return Nullch;
 112
 113 }  /* end of my_getenv() */
 114 /*}}}*/
 115
 116 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 117 void
 118 my_setenv(char *lnm,char *eqv)
 119 /* Define a supervisor-mode logical name in the process table.
 120  * In the future we'll add tables, attribs, and acmodes,
 121  * probably through a different call.
 122  */
 123 {
 124     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 125     unsigned long int retsts, usermode = PSL$C_USER;
 126     $DESCRIPTOR(tabdsc,"LNM$PROCESS");
 127     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 128                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 129
 130     for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
 131     lnmdsc.dsc$w_length = cp1 - lnm;
 132
 133     if (!eqv || !*eqv) {  /* we're deleting a logical name */
 134       retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
 135       if (retsts == SS$_IVLOGNAM) return;
 136       if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
 137       if (!(retsts & 1)) {
 138         retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
 139         if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
 140       }
 141     }
 142     else {
 143       eqvdsc.dsc$w_length = strlen(eqv);
 144       eqvdsc.dsc$a_pointer = eqv;
 145
 146       _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
 147     }
 148
 149 }  /* end of my_setenv() */
 150 /*}}}*/
 151
 152 static char *do_fileify_dirspec(char *, char *, int);
 153 static char *do_tovmsspec(char *, char *, int);
 154
 155 /*{{{int do_rmdir(char *name)*/
 156 int
 157 do_rmdir(char *name)
 158 {
 159     char dirfile[NAM$C_MAXRSS+1];
 160     int retval;
 161     struct stat st;
 162
 163     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 164     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 165     else retval = kill_file(dirfile);
 166     return retval;
 167
 168 }  /* end of do_rmdir */
 169 /*}}}*/
 170
 171 /* kill_file
 172  * Delete any file to which user has control access, regardless of whether
 173  * delete access is explicitly allowed.
 174  * Limitations: User must have write access to parent directory.
 175  *              Does not block signals or ASTs; if interrupted in midstream
 176  *              may leave file with an altered ACL.
 177  * HANDLE WITH CARE!
 178  */
 179 /*{{{int kill_file(char *name)*/
 180 int
 181 kill_file(char *name)
 182 {
 183     char vmsname[NAM$C_MAXRSS+1];
 184     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 185     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 186     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 187     struct myacedef {
 188       unsigned char myace$b_length;
 189       unsigned char myace$b_type;
 190       unsigned short int myace$w_flags;
 191       unsigned long int myace$l_access;
 192       unsigned long int myace$l_ident;
 193     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 194                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 195       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 196      struct itmlst_3
 197        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 198                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 199        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 200        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 201        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 202        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 203
 204     if (!remove(name)) return 0;  /* Can we just get rid of it? */
 205
 206     /* No, so we get our own UIC to use as a rights identifier,
 207      * and the insert an ACE at the head of the ACL which allows us
 208      * to delete the file.
 209      */
 210     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 211     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 212     fildsc.dsc$w_length = strlen(vmsname);
 213     fildsc.dsc$a_pointer = vmsname;
 214     cxt = 0;
 215     newace.myace$l_ident = oldace.myace$l_ident;
 216     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 217       set_errno(EVMSERR);
 218       set_vaxc_errno(aclsts);
 219       return -1;
 220     }
 221     /* Grab any existing ACEs with this identifier in case we fail */
 222     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 223     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 224                     || fndsts == SS$_NOMOREACE ) {
 225       /* Add the new ACE . . . */
 226       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 227         goto yourroom;
 228       if ((rmsts = remove(name))) {
 229         /* We blew it - dir with files in it, no write priv for
 230          * parent directory, etc.  Put things back the way they were. */
 231         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 232           goto yourroom;
 233         if (fndsts & 1) {
 234           addlst[0].bufadr = &oldace;
 235           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 236             goto yourroom;
 237         }
 238       }
 239     }
 240
 241     yourroom:
 242     if (rmsts) {
 243       fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 244       if (aclsts & 1) aclsts = fndsts;
 245     }
 246     if (!(aclsts & 1)) {
 247       set_errno(EVMSERR);
 248       set_vaxc_errno(aclsts);
 249       return -1;
 250     }
 251
 252     return rmsts;
 253
 254 }  /* end of kill_file() */
 255 /*}}}*/
 256
 257 /* my_utime - update modification time of a file
 258  * calling sequence is identical to POSIX utime(), but under
 259  * VMS only the modification time is changed; ODS-2 does not
 260  * maintain access times.  Restrictions differ from the POSIX
 261  * definition in that the time can be changed as long as the
 262  * caller has permission to execute the necessary IO$_MODIFY $QIO;
 263  * no separate checks are made to insure that the caller is the
 264  * owner of the file or has special privs enabled.
 265  * Code here is based on Joe Meadows' FILE utility.
 266  */
 267
 268 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
 269  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
 270  * in 100 ns intervals.
 271  */
 272 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
 273
 274 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
 275 int my_utime(char *file, struct utimbuf *utimes)
 276 {
 277   register int i;
 278   long int bintime[2], len = 2, lowbit, unixtime,
 279            secscale = 10000000; /* seconds --> 100 ns intervals */
 280   unsigned long int chan, iosb[2], retsts;
 281   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
 282   struct FAB myfab = cc$rms_fab;
 283   struct NAM mynam = cc$rms_nam;
 284 #if defined (__DECC) && defined (__VAX)
 285   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
 286    * at least through VMS V6.1, which causes a type-conversion warning.
 287    */
 288 #  pragma message save
 289 #  pragma message disable cvtdiftypes
 290 #endif
 291   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
 292   struct fibdef myfib;
 293 #if defined (__DECC) && defined (__VAX)
 294   /* This should be right after the declaration of myatr, but due
 295    * to a bug in VAX DEC C, this takes effect a statement early.
 296    */
 297 #  pragma message restore
 298 #endif
 299   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
 300                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
 301                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
 302
 303   if (file == NULL || *file == '\0') {
 304     set_errno(ENOENT);
 305     set_vaxc_errno(LIB$_INVARG);
 306     return -1;
 307   }
 308   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
 309
 310   if (utimes != NULL) {
 311     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
 312      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
 313      * Since time_t is unsigned long int, and lib$emul takes a signed long int
 314      * as input, we force the sign bit to be clear by shifting unixtime right
 315      * one bit, then multiplying by an extra factor of 2 in lib$emul().
 316      */
 317     lowbit = (utimes->modtime & 1) ? secscale : 0;
 318     unixtime = (long int) utimes->modtime;
 319     unixtime >> 1;  secscale << 1;
 320     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
 321     if (!(retsts & 1)) {
 322       set_errno(EVMSERR);
 323       set_vaxc_errno(retsts);
 324       return -1;
 325     }
 326     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
 327     if (!(retsts & 1)) {
 328       set_errno(EVMSERR);
 329       set_vaxc_errno(retsts);
 330       return -1;
 331     }
 332   }
 333   else {
 334     /* Just get the current time in VMS format directly */
 335     retsts = sys$gettim(bintime);
 336     if (!(retsts & 1)) {
 337       set_errno(EVMSERR);
 338       set_vaxc_errno(retsts);
 339       return -1;
 340     }
 341   }
 342
 343   myfab.fab$l_fna = vmsspec;
 344   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
 345   myfab.fab$l_nam = &mynam;
 346   mynam.nam$l_esa = esa;
 347   mynam.nam$b_ess = (unsigned char) sizeof esa;
 348   mynam.nam$l_rsa = rsa;
 349   mynam.nam$b_rss = (unsigned char) sizeof rsa;
 350
 351   /* Look for the file to be affected, letting RMS parse the file
 352    * specification for us as well.  I have set errno using only
 353    * values documented in the utime() man page for VMS POSIX.
 354    */
 355   retsts = sys$parse(&myfab,0,0);
 356   if (!(retsts & 1)) {
 357     set_vaxc_errno(retsts);
 358     if      (retsts == RMS$_PRV) set_errno(EACCES);
 359     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
 360     else                         set_errno(EVMSERR);
 361     return -1;
 362   }
 363   retsts = sys$search(&myfab,0,0);
 364   if (!(retsts & 1)) {
 365     set_vaxc_errno(retsts);
 366     if      (retsts == RMS$_PRV) set_errno(EACCES);
 367     else if (retsts == RMS$_FNF) set_errno(ENOENT);
 368     else                         set_errno(EVMSERR);
 369     return -1;
 370   }
 371
 372   devdsc.dsc$w_length = mynam.nam$b_dev;
 373   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
 374
 375   retsts = sys$assign(&devdsc,&chan,0,0);
 376   if (!(retsts & 1)) {
 377     set_vaxc_errno(retsts);
 378     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
 379     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
 380     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
 381     else                               set_errno(EVMSERR);
 382     return -1;
 383   }
 384
 385   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
 386   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
 387
 388   memset((void *) &myfib, 0, sizeof myfib);
 389 #ifdef __DECC
 390   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
 391   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
 392   /* This prevents the revision time of the file being reset to the current
 393    * time as a reqult of our IO$_MODIFY $QIO. */
 394   myfib.fib$l_acctl = FIB$M_NORECORD;
 395 #else
 396   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
 397   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
 398   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
 399 #endif
 400   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
 401   if (retsts & 1) retsts = iosb[0];
 402   if (!(retsts & 1)) {
 403     set_vaxc_errno(retsts);
 404     if (retsts == SS$_NOPRIV) set_errno(EACCES);
 405     else                      set_errno(EVMSERR);
 406     return -1;
 407   }
 408
 409   return 0;
 410 }  /* end of my_utime() */
 411 /*}}}*/
 412
 413 static void
 414 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 415 {
 416   static unsigned long int mbxbufsiz;
 417   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 418
 419   if (!mbxbufsiz) {
 420     /*
 421      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
 422      * preprocessor consant BUFSIZ from stdio.h as the size of the
 423      * 'pipe' mailbox.
 424      */
 425     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 426     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
 427   }
 428   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
 429
 430   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
 431   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
 432
 433 }  /* end of create_mbx() */
 434
 435 /*{{{  my_popen and my_pclose*/
 436 struct pipe_details
 437 {
 438     struct pipe_details *next;
 439     FILE *fp;  /* stdio file pointer to pipe mailbox */
 440     int pid;   /* PID of subprocess */
 441     int mode;  /* == 'r' if pipe open for reading */
 442     int done;  /* subprocess has completed */
 443     unsigned long int completion;  /* termination status of subprocess */
 444 };
 445
 446 struct exit_control_block
 447 {
 448     struct exit_control_block *flink;
 449     unsigned long int   (*exit_routine)();
 450     unsigned long int arg_count;
 451     unsigned long int *status_address;
 452     unsigned long int exit_status;
 453 };
 454
 455 static struct pipe_details *open_pipes = NULL;
 456 static $DESCRIPTOR(nl_desc, "NL:");
 457 static int waitpid_asleep = 0;
 458
 459 static unsigned long int
 460 pipe_exit_routine()
 461 {
 462     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
 463
 464     while (open_pipes != NULL) {
 465       if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
 466         _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
 467         sleep(1);
 468       }
 469       if (!open_pipes->done)  /* We tried to be nice . . . */
 470         _ckvmssts(sys$delprc(&open_pipes->pid,0));
 471       if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
 472     }
 473     return retsts;
 474 }
 475
 476 static struct exit_control_block pipe_exitblock =
 477        {(struct exit_control_block *) 0,
 478         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
 479
 480
 481 static void
 482 popen_completion_ast(struct pipe_details *thispipe)
 483 {
 484   thispipe->done = TRUE;
 485   if (waitpid_asleep) {
 486     waitpid_asleep = 0;
 487     sys$wake(0,0);
 488   }
 489 }
 490
 491 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
 492 FILE *
 493 my_popen(char *cmd, char *mode)
 494 {
 495     static int handler_set_up = FALSE;
 496     char mbxname[64];
 497     unsigned short int chan;
 498     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
 499     struct pipe_details *info;
 500     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
 501                                       DSC$K_CLASS_S, mbxname},
 502                             cmddsc = {0, DSC$K_DTYPE_T,
 503                                       DSC$K_CLASS_S, 0};
 504
 505
 506     New(7001,info,1,struct pipe_details);
 507
 508     /* create mailbox */
 509     create_mbx(&chan,&namdsc);
 510
 511     /* open a FILE* onto it */
 512     info->fp=fopen(mbxname, mode);
 513
 514     /* give up other channel onto it */
 515     _ckvmssts(sys$dassgn(chan));
 516
 517     if (!info->fp)
 518         return Nullfp;
 519
 520     cmddsc.dsc$w_length=strlen(cmd);
 521     cmddsc.dsc$a_pointer=cmd;
 522
 523     info->mode = *mode;
 524     info->done = FALSE;
 525     info->completion=0;
 526
 527     if (*mode == 'r') {
 528       _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
 529                      0  /* name */, &info->pid, &info->completion,
 530                      0, popen_completion_ast,info,0,0,0));
 531     }
 532     else {
 533       _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
 534                      0  /* name */, &info->pid, &info->completion,
 535                      0, popen_completion_ast,info,0,0,0));
 536     }
 537
 538     if (!handler_set_up) {
 539       _ckvmssts(sys$dclexh(&pipe_exitblock));
 540       handler_set_up = TRUE;
 541     }
 542     info->next=open_pipes;  /* prepend to list */
 543     open_pipes=info;
 544
 545     forkprocess = info->pid;
 546     return info->fp;
 547 }
 548 /*}}}*/
 549
 550 /*{{{  I32 my_pclose(FILE *fp)*/
 551 I32 my_pclose(FILE *fp)
 552 {
 553     struct pipe_details *info, *last = NULL;
 554     unsigned long int retsts;
 555
 556     for (info = open_pipes; info != NULL; last = info, info = info->next)
 557         if (info->fp == fp) break;
 558
 559     if (info == NULL)
 560       /* get here => no such pipe open */
 561       croak("No such pipe open");
 562
 563     if (info->done) retsts = info->completion;
 564     else waitpid(info->pid,(int *) &retsts,0);
 565
 566     fclose(info->fp);
 567
 568     /* remove from list of open pipes */
 569     if (last) last->next = info->next;
 570     else open_pipes = info->next;
 571     Safefree(info);
 572
 573     return retsts;
 574
 575 }  /* end of my_pclose() */
 576
 577 /* sort-of waitpid; use only with popen() */
 578 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
 579 unsigned long int
 580 waitpid(unsigned long int pid, int *statusp, int flags)
 581 {
 582     struct pipe_details *info;
 583
 584     for (info = open_pipes; info != NULL; info = info->next)
 585         if (info->pid == pid) break;
 586
 587     if (info != NULL) {  /* we know about this child */
 588       while (!info->done) {
 589         waitpid_asleep = 1;
 590         sys$hiber();
 591       }
 592
 593       *statusp = info->completion;
 594       return pid;
 595     }
 596     else {  /* we haven't heard of this child */
 597       $DESCRIPTOR(intdsc,"0 00:00:01");
 598       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
 599       unsigned long int interval[2],sts;
 600
 601       if (dowarn) {
 602         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
 603         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
 604         if (ownerpid != mypid)
 605           warn("pid %d not a child",pid);
 606       }
 607
 608       _ckvmssts(sys$bintim(&intdsc,interval));
 609       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
 610         _ckvmssts(sys$schdwk(0,0,interval,0));
 611         _ckvmssts(sys$hiber());
 612       }
 613       _ckvmssts(sts);
 614
 615       /* There's no easy way to find the termination status a child we're
 616        * not aware of beforehand.  If we're really interested in the future,
 617        * we can go looking for a termination mailbox, or chase after the
 618        * accounting record for the process.
 619        */
 620       *statusp = 0;
 621       return pid;
 622     }
 623
 624 }  /* end of waitpid() */
 625 /*}}}*/
 626 /*}}}*/
 627 /*}}}*/
 628
 629 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
 630 char *
 631 my_gconvert(double val, int ndig, int trail, char *buf)
 632 {
 633   static char __gcvtbuf[DBL_DIG+1];
 634   char *loc;
 635
 636   loc = buf ? buf : __gcvtbuf;
 637   if (val) {
 638     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
 639     return gcvt(val,ndig,loc);
 640   }
 641   else {
 642     loc[0] = '0'; loc[1] = '\0';
 643     return loc;
 644   }
 645
 646 }
 647 /*}}}*/
 648
 649 /*
 650 ** The following routines are provided to make life easier when
 651 ** converting among VMS-style and Unix-style directory specifications.
 652 ** All will take input specifications in either VMS or Unix syntax. On
 653 ** failure, all return NULL.  If successful, the routines listed below
 654 ** return a pointer to a buffer containing the appropriately
 655 ** reformatted spec (and, therefore, subsequent calls to that routine
 656 ** will clobber the result), while the routines of the same names with
 657 ** a _ts suffix appended will return a pointer to a mallocd string
 658 ** containing the appropriately reformatted spec.
 659 ** In all cases, only explicit syntax is altered; no check is made that
 660 ** the resulting string is valid or that the directory in question
 661 ** actually exists.
 662 **
 663 **   fileify_dirspec() - convert a directory spec into the name of the
 664 **     directory file (i.e. what you can stat() to see if it's a dir).
 665 **     The style (VMS or Unix) of the result is the same as the style
 666 **     of the parameter passed in.
 667 **   pathify_dirspec() - convert a directory spec into a path (i.e.
 668 **     what you prepend to a filename to indicate what directory it's in).
 669 **     The style (VMS or Unix) of the result is the same as the style
 670 **     of the parameter passed in.
 671 **   tounixpath() - convert a directory spec into a Unix-style path.
 672 **   tovmspath() - convert a directory spec into a VMS-style path.
 673 **   tounixspec() - convert any file spec into a Unix-style file spec.
 674 **   tovmsspec() - convert any file spec into a VMS-style spec.
 675 **
 676 ** Copyright 1995 by Charles Bailey  <bailey@genetics.upenn.edu>
 677 ** Permission is given for non-commercial use of this code according
 678 ** to the terms of the GNU General Public License or the Perl
 679 ** Artistic License.  Copies of each may be found in the Perl
 680 ** standard distribution.  This software is supplied without any
 681 ** warranty whatsoever.
 682  */
 683
 684 static char *do_tounixspec(char *, char *, int);
 685
 686 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
 687 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
 688 {
 689     static char __fileify_retbuf[NAM$C_MAXRSS+1];
 690     unsigned long int dirlen, retlen, addmfd = 0;
 691     char *retspec, *cp1, *cp2, *lastdir;
 692     char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
 693
 694     if (dir == NULL) return NULL;
 695     dirlen = strlen(dir);
 696     if (dir[dirlen-1] == '/') dir[--dirlen] = '\0';
 697     if (!strpbrk(dir+1,"/]>:")) {
 698       strcpy(trndir,*dir == '/' ? dir + 1: dir);
 699       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir) != NULL) ;
 700       dir = trndir;
 701       dirlen = strlen(dir);
 702     }
 703
 704     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
 705       if (dir[0] == '.') {
 706         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
 707           return do_fileify_dirspec("[]",buf,ts);
 708         else if (dir[1] == '.' &&
 709                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
 710           return do_fileify_dirspec("[-]",buf,ts);
 711       }
 712       if (dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
 713         dirlen -= 1;                 /* to last element */
 714         lastdir = strrchr(dir,'/');
 715       }
 716       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
 717         do {
 718           if (*(cp1+2) == '.') cp1++;
 719           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
 720             addmfd = 1;
 721             break;
 722           }
 723           cp1++;
 724         } while ((cp1 = strstr(cp1,"/.")) != NULL);
 725         /* If we have a relative path, VMSify it and let the VMS code
 726          * below expand it, rather than repeating the code here */
 727         if (addmfd) {
 728           if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
 729           if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
 730           return do_tounixspec(trndir,buf,ts);
 731         }
 732       }
 733       else {
 734         if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
 735         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
 736           if (toupper(*(cp2+1)) == 'D' &&    /* Yep.  Is it .dir? */
 737               toupper(*(cp2+2)) == 'I' &&
 738               toupper(*(cp2+3)) == 'R') {
 739             if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
 740               if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
 741                 set_errno(ENOTDIR);                      /* Bzzt. */
 742                 set_vaxc_errno(RMS$_DIR);
 743                 return NULL;
 744               }
 745             }
 746             dirlen = cp2 - dir;
 747           }
 748           else {  /* There's a type, and it's not .dir.  Bzzt. */
 749             set_errno(ENOTDIR);
 750             set_vaxc_errno(RMS$_DIR);
 751             return NULL;
 752           }
 753         }
 754       }
 755       /* If we lead off with a device or rooted logical, add the MFD
 756          if we're specifying a top-level directory. */
 757       if (lastdir && *dir == '/') {
 758         addmfd = 1;
 759         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
 760           if (*cp1 == '/') {
 761             addmfd = 0;
 762             break;
 763           }
 764         }
 765       }
 766       retlen = dirlen + (addmfd ? 13 : 6);
 767       if (buf) retspec = buf;
 768       else if (ts) New(7009,retspec,retlen+1,char);
 769       else retspec = __fileify_retbuf;
 770       if (addmfd) {
 771         dirlen = lastdir - dir;
 772         memcpy(retspec,dir,dirlen);
 773         strcpy(&retspec[dirlen],"/000000");
 774         strcpy(&retspec[dirlen+7],lastdir);
 775       }
 776       else {
 777         memcpy(retspec,dir,dirlen);
 778         retspec[dirlen] = '\0';
 779       }
 780       /* We've picked up everything up to the directory file name.
 781          Now just add the type and version, and we're set. */
 782       strcat(retspec,".dir;1");
 783       return retspec;
 784     }
 785     else {  /* VMS-style directory spec */
 786       char esa[NAM$C_MAXRSS+1], term;
 787       unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver;
 788       struct FAB dirfab = cc$rms_fab;
 789       struct NAM savnam, dirnam = cc$rms_nam;
 790
 791       dirfab.fab$b_fns = strlen(dir);
 792       dirfab.fab$l_fna = dir;
 793       dirfab.fab$l_nam = &dirnam;
 794       dirfab.fab$l_dna = ".DIR;1";
 795       dirfab.fab$b_dns = 6;
 796       dirnam.nam$b_ess = NAM$C_MAXRSS;
 797       dirnam.nam$l_esa = esa;
 798       if (!((sts = sys$parse(&dirfab))&1)) {
 799         if (dirfab.fab$l_sts == RMS$_DIR) {
 800           dirnam.nam$b_nop |= NAM$M_SYNCHK;
 801           sts = sys$parse(&dirfab) & 1;
 802         }
 803         if (!sts) {
 804           set_errno(EVMSERR);
 805           set_vaxc_errno(dirfab.fab$l_sts);
 806           return NULL;
 807         }
 808       }
 809       else {
 810         savnam = dirnam;
 811         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
 812           /* Yes; fake the fnb bits so we'll check type below */
 813           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
 814         }
 815         else {
 816           if (dirfab.fab$l_sts != RMS$_FNF) {
 817             set_errno(EVMSERR);
 818             set_vaxc_errno(dirfab.fab$l_sts);
 819             return NULL;
 820           }
 821           dirnam = savnam; /* No; just work with potential name */
 822         }
 823       }
 824       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
 825         cp1 = strchr(esa,']');
 826         if (!cp1) cp1 = strchr(esa,'>');
 827         if (cp1) {  /* Should always be true */
 828           dirnam.nam$b_esl -= cp1 - esa - 1;
 829           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
 830         }
 831       }
 832       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
 833         /* Yep; check version while we're at it, if it's there. */
 834         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
 835         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
 836           /* Something other than .DIR[;1].  Bzzt. */
 837           set_errno(ENOTDIR);
 838           set_vaxc_errno(RMS$_DIR);
 839           return NULL;
 840         }
 841       }
 842       esa[dirnam.nam$b_esl] = '\0';
 843       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
 844         /* They provided at least the name; we added the type, if necessary, */
 845         if (buf) retspec = buf;                            /* in sys$parse() */
 846         else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
 847         else retspec = __fileify_retbuf;
 848         strcpy(retspec,esa);
 849         return retspec;
 850       }
 851       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
 852       if (cp1 == NULL) return NULL; /* should never happen */
 853       term = *cp1;
 854       *cp1 = '\0';
 855       retlen = strlen(esa);
 856       if ((cp1 = strrchr(esa,'.')) != NULL) {
 857         /* There's more than one directory in the path.  Just roll back. */
 858         *cp1 = term;
 859         if (buf) retspec = buf;
 860         else if (ts) New(7011,retspec,retlen+7,char);
 861         else retspec = __fileify_retbuf;
 862         strcpy(retspec,esa);
 863       }
 864       else {
 865         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
 866           /* Go back and expand rooted logical name */
 867           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
 868           if (!(sys$parse(&dirfab) & 1)) {
 869             set_errno(EVMSERR);
 870             set_vaxc_errno(dirfab.fab$l_sts);
 871             return NULL;
 872           }
 873           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
 874           if (buf) retspec = buf;
 875           else if (ts) New(7012,retspec,retlen+16,char);
 876           else retspec = __fileify_retbuf;
 877           cp1 = strstr(esa,"][");
 878           dirlen = cp1 - esa;
 879           memcpy(retspec,esa,dirlen);
 880           if (!strncmp(cp1+2,"000000]",7)) {
 881             retspec[dirlen-1] = '\0';
 882             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
 883             if (*cp1 == '.') *cp1 = ']';
 884             else {
 885               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
 886               memcpy(cp1+1,"000000]",7);
 887             }
 888           }
 889           else {
 890             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
 891             retspec[retlen] = '\0';
 892             /* Convert last '.' to ']' */
 893             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
 894             if (*cp1 == '.') *cp1 = ']';
 895             else {
 896               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
 897               memcpy(cp1+1,"000000]",7);
 898             }
 899           }
 900         }
 901         else {  /* This is a top-level dir.  Add the MFD to the path. */
 902           if (buf) retspec = buf;
 903           else if (ts) New(7012,retspec,retlen+16,char);
 904           else retspec = __fileify_retbuf;
 905           cp1 = esa;
 906           cp2 = retspec;
 907           while (*cp1 != ':') *(cp2++) = *(cp1++);
 908           strcpy(cp2,":[000000]");
 909           cp1 += 2;
 910           strcpy(cp2+9,cp1);
 911         }
 912       }
 913       /* We've set up the string up through the filename.  Add the
 914          type and version, and we're done. */
 915       strcat(retspec,".DIR;1");
 916       return retspec;
 917     }
 918 }  /* end of do_fileify_dirspec() */
 919 /*}}}*/
 920 /* External entry points */
 921 char *fileify_dirspec(char *dir, char *buf)
 922 { return do_fileify_dirspec(dir,buf,0); }
 923 char *fileify_dirspec_ts(char *dir, char *buf)
 924 { return do_fileify_dirspec(dir,buf,1); }
 925
 926 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
 927 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
 928 {
 929     static char __pathify_retbuf[NAM$C_MAXRSS+1];
 930     unsigned long int retlen;
 931     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
 932
 933     if (dir == NULL) return NULL;
 934
 935     strcpy(trndir,dir);
 936     while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
 937     dir = trndir;
 938
 939     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
 940       if (*dir == '.' && (*(dir+1) == '\0' ||
 941                           (*(dir+1) == '.' && *(dir+2) == '\0')))
 942         retlen = 2 + (*(dir+1) != '\0');
 943       else {
 944         if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
 945         if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
 946           if (toupper(*(cp2+1)) == 'D' &&  /* They specified .dir. */
 947               toupper(*(cp2+2)) == 'I' &&  /* Trim it off. */
 948               toupper(*(cp2+3)) == 'R') {
 949             retlen = cp2 - dir + 1;
 950           }
 951           else {  /* Some other file type.  Bzzt. */
 952             set_errno(ENOTDIR);
 953             set_vaxc_errno(RMS$_DIR);
 954             return NULL;
 955           }
 956         }
 957         else {  /* No file type present.  Treat the filename as a directory. */
 958           retlen = strlen(dir) + 1;
 959         }
 960       }
 961       if (buf) retpath = buf;
 962       else if (ts) New(7013,retpath,retlen+1,char);
 963       else retpath = __pathify_retbuf;
 964       strncpy(retpath,dir,retlen-1);
 965       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
 966         retpath[retlen-1] = '/';      /* with '/', add it. */
 967         retpath[retlen] = '\0';
 968       }
 969       else retpath[retlen-1] = '\0';
 970     }
 971     else {  /* VMS-style directory spec */
 972       char esa[NAM$C_MAXRSS+1];
 973       unsigned long int sts, cmplen;
 974       struct FAB dirfab = cc$rms_fab;
 975       struct NAM savnam, dirnam = cc$rms_nam;
 976
 977       dirfab.fab$b_fns = strlen(dir);
 978       dirfab.fab$l_fna = dir;
 979       if (dir[dirfab.fab$b_fns-1] == ']' ||
 980           dir[dirfab.fab$b_fns-1] == '>' ||
 981           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
 982         if (buf) retpath = buf;
 983         else if (ts) New(7014,retpath,strlen(dir)+1,char);
 984         else retpath = __pathify_retbuf;
 985         strcpy(retpath,dir);
 986         return retpath;
 987       }
 988       dirfab.fab$l_dna = ".DIR;1";
 989       dirfab.fab$b_dns = 6;
 990       dirfab.fab$l_nam = &dirnam;
 991       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
 992       dirnam.nam$l_esa = esa;
 993       if (!((sts = sys$parse(&dirfab))&1)) {
 994         if (dirfab.fab$l_sts == RMS$_DIR) {
 995           dirnam.nam$b_nop |= NAM$M_SYNCHK;
 996           sts = sys$parse(&dirfab) & 1;
 997         }
 998         if (!sts) {
 999           set_errno(EVMSERR);
1000           set_vaxc_errno(dirfab.fab$l_sts);
1001           return NULL;
1002         }
1003       }
1004       else {
1005         savnam = dirnam;
1006         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
1007           if (dirfab.fab$l_sts != RMS$_FNF) {
1008             set_errno(EVMSERR);
1009             set_vaxc_errno(dirfab.fab$l_sts);
1010             return NULL;
1011           }
1012           dirnam = savnam; /* No; just work with potential name */
1013         }
1014       }
1015       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1016         /* Yep; check version while we're at it, if it's there. */
1017         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1018         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1019           /* Something other than .DIR[;1].  Bzzt. */
1020           set_errno(ENOTDIR);
1021           set_vaxc_errno(RMS$_DIR);
1022           return NULL;
1023         }
1024       }
1025       /* OK, the type was fine.  Now pull any file name into the
1026          directory path. */
1027       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1028       else {
1029         cp1 = strrchr(esa,'>');
1030         *dirnam.nam$l_type = '>';
1031       }
1032       *cp1 = '.';
1033       *(dirnam.nam$l_type + 1) = '\0';
1034       retlen = dirnam.nam$l_type - esa + 2;
1035       if (buf) retpath = buf;
1036       else if (ts) New(7014,retpath,retlen,char);
1037       else retpath = __pathify_retbuf;
1038       strcpy(retpath,esa);
1039     }
1040
1041     return retpath;
1042 }  /* end of do_pathify_dirspec() */
1043 /*}}}*/
1044 /* External entry points */
1045 char *pathify_dirspec(char *dir, char *buf)
1046 { return do_pathify_dirspec(dir,buf,0); }
1047 char *pathify_dirspec_ts(char *dir, char *buf)
1048 { return do_pathify_dirspec(dir,buf,1); }
1049
1050 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1051 static char *do_tounixspec(char *spec, char *buf, int ts)
1052 {
1053   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1054   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1055   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1056
1057   if (spec == NULL) return NULL;
1058   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1059   if (buf) rslt = buf;
1060   else if (ts) {
1061     retlen = strlen(spec);
1062     cp1 = strchr(spec,'[');
1063     if (!cp1) cp1 = strchr(spec,'<');
1064     if (cp1) {
1065       for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS  '-' ==> Unix '../' */
1066     }
1067     New(7015,rslt,retlen+1+2*dashes,char);
1068   }
1069   else rslt = __tounixspec_retbuf;
1070   if (strchr(spec,'/') != NULL) {
1071     strcpy(rslt,spec);
1072     return rslt;
1073   }
1074
1075   cp1 = rslt;
1076   cp2 = spec;
1077   dirend = strrchr(spec,']');
1078   if (dirend == NULL) dirend = strrchr(spec,'>');
1079   if (dirend == NULL) dirend = strchr(spec,':');
1080   if (dirend == NULL) {
1081     strcpy(rslt,spec);
1082     return rslt;
1083   }
1084   if (*cp2 != '[') {
1085     *(cp1++) = '/';
1086   }
1087   else {  /* the VMS spec begins with directories */
1088     cp2++;
1089     if (*cp2 == '-') {
1090       while (*cp2 == '-') {
1091         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1092         cp2++;
1093       }
1094       if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1095         if (ts) Safefree(rslt);                        /* filespecs like */
1096         set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [--foo.bar] */
1097         return NULL;
1098       }
1099       cp2++;
1100     }
1101     else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1102       *(cp1++) = '/';
1103       if (getcwd(tmp,sizeof tmp,1) == NULL) {
1104         if (ts) Safefree(rslt);
1105         return NULL;
1106       }
1107       do {
1108         cp3 = tmp;
1109         while (*cp3 != ':' && *cp3) cp3++;
1110         *(cp3++) = '\0';
1111         if (strchr(cp3,']') != NULL) break;
1112       } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1113       cp3 = tmp;
1114       while (*cp3) *(cp1++) = *(cp3++);
1115       *(cp1++) = '/';
1116       if (ts &&
1117           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1118         int offset = cp1 - rslt;
1119
1120         retlen = devlen + dirlen;
1121         Renew(rslt,retlen+1+2*dashes,char);
1122         cp1 = rslt + offset;
1123       }
1124     }
1125     else cp2++;
1126   }
1127   for (; cp2 <= dirend; cp2++) {
1128     if (*cp2 == ':') {
1129       *(cp1++) = '/';
1130       if (*(cp2+1) == '[') cp2++;
1131     }
1132     else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1133     else if (*cp2 == '.') {
1134       *(cp1++) = '/';
1135       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1136         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1137                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1138         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1139             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1140       }
1141     }
1142     else if (*cp2 == '-') {
1143       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1144         while (*cp2 == '-') {
1145           cp2++;
1146           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1147         }
1148         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1149           if (ts) Safefree(rslt);                        /* filespecs like */
1150           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [--foo.bar] */
1151           return NULL;
1152         }
1153         cp2++;
1154       }
1155       else *(cp1++) = *cp2;
1156     }
1157     else *(cp1++) = *cp2;
1158   }
1159   while (*cp2) *(cp1++) = *(cp2++);
1160   *cp1 = '\0';
1161
1162   return rslt;
1163
1164 }  /* end of do_tounixspec() */
1165 /*}}}*/
1166 /* External entry points */
1167 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1168 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1169
1170 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1171 static char *do_tovmsspec(char *path, char *buf, int ts) {
1172   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1173   char *rslt, *dirend;
1174   register char *cp1, *cp2;
1175   unsigned long int infront = 0, hasdir = 1;
1176
1177   if (path == NULL) return NULL;
1178   if (buf) rslt = buf;
1179   else if (ts) New(7016,rslt,strlen(path)+9,char);
1180   else rslt = __tovmsspec_retbuf;
1181   if (strpbrk(path,"]:>") ||
1182       (dirend = strrchr(path,'/')) == NULL) {
1183     if (path[0] == '.') {
1184       if (path[1] == '\0') strcpy(rslt,"[]");
1185       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1186       else strcpy(rslt,path); /* probably garbage */
1187     }
1188     else strcpy(rslt,path);
1189     return rslt;
1190   }
1191   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.."? */
1192     if (!*(dirend+2)) dirend +=2;
1193     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1194   }
1195   cp1 = rslt;
1196   cp2 = path;
1197   if (*cp2 == '/') {
1198     char trndev[NAM$C_MAXRSS+1];
1199     int islnm, rooted;
1200     STRLEN trnend;
1201
1202     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1203     *cp1 = '\0';
1204     islnm =  (my_trnlnm(rslt,trndev) != Nullch);
1205     trnend = islnm ? strlen(trndev) - 1 : 0;
1206     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1207     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1208     /* If the first element of the path is a logical name, determine
1209      * whether it has to be translated so we can add more directories. */
1210     if (!islnm || rooted) {
1211       *(cp1++) = ':';
1212       *(cp1++) = '[';
1213       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1214       else cp2++;
1215     }
1216     else {
1217       if (cp2 != dirend) {
1218         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1219         strcpy(rslt,trndev);
1220         cp1 = rslt + trnend;
1221         *(cp1++) = '.';
1222         cp2++;
1223       }
1224       else {
1225         *(cp1++) = ':';
1226         hasdir = 0;
1227       }
1228     }
1229   }
1230   else {
1231     *(cp1++) = '[';
1232     if (*cp2 == '.') {
1233       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1234         cp2 += 2;         /* skip over "./" - it's redundant */
1235         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
1236       }
1237       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1238         *(cp1++) = '-';                                 /* "../" --> "-" */
1239         cp2 += 3;
1240       }
1241       if (cp2 > dirend) cp2 = dirend;
1242     }
1243     else *(cp1++) = '.';
1244   }
1245   for (; cp2 < dirend; cp2++) {
1246     if (*cp2 == '/') {
1247       if (*(cp1-1) != '.') *(cp1++) = '.';
1248       infront = 0;
1249     }
1250     else if (!infront && *cp2 == '.') {
1251       if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
1252       else if (*(cp2+1) == '\0') { cp2++; break; }
1253       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1254         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1255         else if (*(cp1-2) == '[') *(cp1-1) = '-';
1256         else {  /* back up over previous directory name */
1257           cp1--;
1258           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1259           if (*(cp1-1) == '[') {
1260             memcpy(cp1,"000000.",7);
1261             cp1 += 7;
1262           }
1263         }
1264         cp2 += 2;
1265         if (cp2 == dirend) {
1266           if (*(cp1-1) == '.') cp1--;
1267           break;
1268         }
1269       }
1270       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
1271     }
1272     else {
1273       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
1274       if (*cp2 == '/')      *(cp1++) = '.';
1275       else if (*cp2 == '.') *(cp1++) = '_';
1276       else                  *(cp1++) =  *cp2;
1277       infront = 1;
1278     }
1279   }
1280   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1281   if (hasdir) *(cp1++) = ']';
1282   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
1283   while (*cp2) *(cp1++) = *(cp2++);
1284   *cp1 = '\0';
1285
1286   return rslt;
1287
1288 }  /* end of do_tovmsspec() */
1289 /*}}}*/
1290 /* External entry points */
1291 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1292 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1293
1294 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1295 static char *do_tovmspath(char *path, char *buf, int ts) {
1296   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1297   int vmslen;
1298   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1299
1300   if (path == NULL) return NULL;
1301   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1302   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1303   if (buf) return buf;
1304   else if (ts) {
1305     vmslen = strlen(vmsified);
1306     New(7017,cp,vmslen+1,char);
1307     memcpy(cp,vmsified,vmslen);
1308     cp[vmslen] = '\0';
1309     return cp;
1310   }
1311   else {
1312     strcpy(__tovmspath_retbuf,vmsified);
1313     return __tovmspath_retbuf;
1314   }
1315
1316 }  /* end of do_tovmspath() */
1317 /*}}}*/
1318 /* External entry points */
1319 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1320 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1321
1322
1323 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1324 static char *do_tounixpath(char *path, char *buf, int ts) {
1325   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1326   int unixlen;
1327   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1328
1329   if (path == NULL) return NULL;
1330   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1331   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1332   if (buf) return buf;
1333   else if (ts) {
1334     unixlen = strlen(unixified);
1335     New(7017,cp,unixlen+1,char);
1336     memcpy(cp,unixified,unixlen);
1337     cp[unixlen] = '\0';
1338     return cp;
1339   }
1340   else {
1341     strcpy(__tounixpath_retbuf,unixified);
1342     return __tounixpath_retbuf;
1343   }
1344
1345 }  /* end of do_tounixpath() */
1346 /*}}}*/
1347 /* External entry points */
1348 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1349 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1350
1351 /*
1352  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
1353  *
1354  *****************************************************************************
1355  *                                                                           *
1356  *  Copyright (C) 1989-1994 by                                               *
1357  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
1358  *                                                                           *
1359  *  Permission is hereby  granted for the reproduction of this software,     *
1360  *  on condition that this copyright notice is included in the reproduction, *
1361  *  and that such reproduction is not for purposes of profit or material     *
1362  *  gain.                                                                    *
1363  *                                                                           *
1364  *  27-Aug-1994 Modified for inclusion in perl5                              *
1365  *              by Charles Bailey  bailey@genetics.upenn.edu                 *
1366  *****************************************************************************
1367  */
1368
1369 /*
1370  * getredirection() is intended to aid in porting C programs
1371  * to VMS (Vax-11 C).  The native VMS environment does not support
1372  * '>' and '<' I/O redirection, or command line wild card expansion,
1373  * or a command line pipe mechanism using the '|' AND background
1374  * command execution '&'.  All of these capabilities are provided to any
1375  * C program which calls this procedure as the first thing in the
1376  * main program.
1377  * The piping mechanism will probably work with almost any 'filter' type
1378  * of program.  With suitable modification, it may useful for other
1379  * portability problems as well.
1380  *
1381  * Author:  Mark Pizzolato      mark@infocomm.com
1382  */
1383 struct list_item
1384     {
1385     struct list_item *next;
1386     char *value;
1387     };
1388
1389 static void add_item(struct list_item **head,
1390                      struct list_item **tail,
1391                      char *value,
1392                      int *count);
1393
1394 static void expand_wild_cards(char *item,
1395                               struct list_item **head,
1396                               struct list_item **tail,
1397                               int *count);
1398
1399 static int background_process(int argc, char **argv);
1400
1401 static void pipe_and_fork(char **cmargv);
1402
1403 /*{{{ void getredirection(int *ac, char ***av)*/
1404 void
1405 getredirection(int *ac, char ***av)
1406 /*
1407  * Process vms redirection arg's.  Exit if any error is seen.
1408  * If getredirection() processes an argument, it is erased
1409  * from the vector.  getredirection() returns a new argc and argv value.
1410  * In the event that a background command is requested (by a trailing "&"),
1411  * this routine creates a background subprocess, and simply exits the program.
1412  *
1413  * Warning: do not try to simplify the code for vms.  The code
1414  * presupposes that getredirection() is called before any data is
1415  * read from stdin or written to stdout.
1416  *
1417  * Normal usage is as follows:
1418  *
1419  *      main(argc, argv)
1420  *      int             argc;
1421  *      char            *argv[];
1422  *      {
1423  *              getredirection(&argc, &argv);
1424  *      }
1425  */
1426 {
1427     int                 argc = *ac;     /* Argument Count         */
1428     char                **argv = *av;   /* Argument Vector        */
1429     char                *ap;            /* Argument pointer       */
1430     int                 j;              /* argv[] index           */
1431     int                 item_count = 0; /* Count of Items in List */
1432     struct list_item    *list_head = 0; /* First Item in List       */
1433     struct list_item    *list_tail;     /* Last Item in List        */
1434     char                *in = NULL;     /* Input File Name          */
1435     char                *out = NULL;    /* Output File Name         */
1436     char                *outmode = "w"; /* Mode to Open Output File */
1437     char                *err = NULL;    /* Error File Name          */
1438     char                *errmode = "w"; /* Mode to Open Error File  */
1439     int                 cmargc = 0;     /* Piped Command Arg Count  */
1440     char                **cmargv = NULL;/* Piped Command Arg Vector */
1441
1442     /*
1443      * First handle the case where the last thing on the line ends with
1444      * a '&'.  This indicates the desire for the command to be run in a
1445      * subprocess, so we satisfy that desire.
1446      */
1447     ap = argv[argc-1];
1448     if (0 == strcmp("&", ap))
1449         exit(background_process(--argc, argv));
1450     if (*ap && '&' == ap[strlen(ap)-1])
1451         {
1452         ap[strlen(ap)-1] = '\0';
1453         exit(background_process(argc, argv));
1454         }
1455     /*
1456      * Now we handle the general redirection cases that involve '>', '>>',
1457      * '<', and pipes '|'.
1458      */
1459     for (j = 0; j < argc; ++j)
1460         {
1461         if (0 == strcmp("<", argv[j]))
1462             {
1463             if (j+1 >= argc)
1464                 {
1465                 fprintf(stderr,"No input file after < on command line");
1466                 exit(LIB$_WRONUMARG);
1467                 }
1468             in = argv[++j];
1469             continue;
1470             }
1471         if ('<' == *(ap = argv[j]))
1472             {
1473             in = 1 + ap;
1474             continue;
1475             }
1476         if (0 == strcmp(">", ap))
1477             {
1478             if (j+1 >= argc)
1479                 {
1480                 fprintf(stderr,"No output file after > on command line");
1481                 exit(LIB$_WRONUMARG);
1482                 }
1483             out = argv[++j];
1484             continue;
1485             }
1486         if ('>' == *ap)
1487             {
1488             if ('>' == ap[1])
1489                 {
1490                 outmode = "a";
1491                 if ('\0' == ap[2])
1492                     out = argv[++j];
1493                 else
1494                     out = 2 + ap;
1495                 }
1496             else
1497                 out = 1 + ap;
1498             if (j >= argc)
1499                 {
1500                 fprintf(stderr,"No output file after > or >> on command line");
1501                 exit(LIB$_WRONUMARG);
1502                 }
1503             continue;
1504             }
1505         if (('2' == *ap) && ('>' == ap[1]))
1506             {
1507             if ('>' == ap[2])
1508                 {
1509                 errmode = "a";
1510                 if ('\0' == ap[3])
1511                     err = argv[++j];
1512                 else
1513                     err = 3 + ap;
1514                 }
1515             else
1516                 if ('\0' == ap[2])
1517                     err = argv[++j];
1518                 else
1519                     err = 2 + ap;
1520             if (j >= argc)
1521                 {
1522                 fprintf(stderr,"No output file after 2> or 2>> on command line");
1523                 exit(LIB$_WRONUMARG);
1524                 }
1525             continue;
1526             }
1527         if (0 == strcmp("|", argv[j]))
1528             {
1529             if (j+1 >= argc)
1530                 {
1531                 fprintf(stderr,"No command into which to pipe on command line");
1532                 exit(LIB$_WRONUMARG);
1533                 }
1534             cmargc = argc-(j+1);
1535             cmargv = &argv[j+1];
1536             argc = j;
1537             continue;
1538             }
1539         if ('|' == *(ap = argv[j]))
1540             {
1541             ++argv[j];
1542             cmargc = argc-j;
1543             cmargv = &argv[j];
1544             argc = j;
1545             continue;
1546             }
1547         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1548         }
1549     /*
1550      * Allocate and fill in the new argument vector, Some Unix's terminate
1551      * the list with an extra null pointer.
1552      */
1553     New(7002, argv, item_count+1, char *);
1554     *av = argv;
1555     for (j = 0; j < item_count; ++j, list_head = list_head->next)
1556         argv[j] = list_head->value;
1557     *ac = item_count;
1558     if (cmargv != NULL)
1559         {
1560         if (out != NULL)
1561             {
1562             fprintf(stderr,"'|' and '>' may not both be specified on command line");
1563             exit(LIB$_INVARGORD);
1564             }
1565         pipe_and_fork(cmargv);
1566         }
1567
1568     /* Check for input from a pipe (mailbox) */
1569
1570     if (1 == isapipe(0))
1571         {
1572         char mbxname[L_tmpnam];
1573         long int bufsize;
1574         long int dvi_item = DVI$_DEVBUFSIZ;
1575         $DESCRIPTOR(mbxnam, "");
1576         $DESCRIPTOR(mbxdevnam, "");
1577
1578         /* Input from a pipe, reopen it in binary mode to disable       */
1579         /* carriage control processing.                                 */
1580
1581         if (in != NULL)
1582             {
1583             fprintf(stderr,"'|' and '<' may not both be specified on command line");
1584             exit(LIB$_INVARGORD);
1585             }
1586         fgetname(stdin, mbxname,1);
1587         mbxnam.dsc$a_pointer = mbxname;
1588         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1589         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1590         mbxdevnam.dsc$a_pointer = mbxname;
1591         mbxdevnam.dsc$w_length = sizeof(mbxname);
1592         dvi_item = DVI$_DEVNAM;
1593         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1594         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1595         set_errno(0);
1596         set_vaxc_errno(1);
1597         freopen(mbxname, "rb", stdin);
1598         if (errno != 0)
1599             {
1600             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1601             exit(vaxc$errno);
1602             }
1603         }
1604     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1605         {
1606         fprintf(stderr,"Can't open input file %s as stdin",in);
1607         exit(vaxc$errno);
1608         }
1609     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1610         {
1611         fprintf(stderr,"Can't open output file %s as stdout",out);
1612         exit(vaxc$errno);
1613         }
1614     if (err != NULL) {
1615         FILE *tmperr;
1616         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1617             {
1618             fprintf(stderr,"Can't open error file %s as stderr",err);
1619             exit(vaxc$errno);
1620             }
1621             fclose(tmperr);
1622             if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1623                 {
1624                 exit(vaxc$errno);
1625                 }
1626         }
1627 #ifdef ARGPROC_DEBUG
1628     fprintf(stderr, "Arglist:\n");
1629     for (j = 0; j < *ac;  ++j)
1630         fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1631 #endif
1632 }  /* end of getredirection() */
1633 /*}}}*/
1634
1635 static void add_item(struct list_item **head,
1636                      struct list_item **tail,
1637                      char *value,
1638                      int *count)
1639 {
1640     if (*head == 0)
1641         {
1642         New(7003,*head,1,struct list_item);
1643         *tail = *head;
1644         }
1645     else {
1646         New(7004,(*tail)->next,1,struct list_item);
1647         *tail = (*tail)->next;
1648         }
1649     (*tail)->value = value;
1650     ++(*count);
1651 }
1652
1653 static void expand_wild_cards(char *item,
1654                               struct list_item **head,
1655                               struct list_item **tail,
1656                               int *count)
1657 {
1658 int expcount = 0;
1659 unsigned long int context = 0;
1660 int isunix = 0;
1661 int status_value;
1662 char *had_version;
1663 char *had_device;
1664 int had_directory;
1665 char *devdir;
1666 char vmsspec[NAM$C_MAXRSS+1];
1667 $DESCRIPTOR(filespec, "");
1668 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1669 $DESCRIPTOR(resultspec, "");
1670 unsigned long int zero = 0;
1671
1672     if (strcspn(item, "*%") == strlen(item))
1673         {
1674         add_item(head, tail, item, count);
1675         return;
1676         }
1677     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1678     resultspec.dsc$b_class = DSC$K_CLASS_D;
1679     resultspec.dsc$a_pointer = NULL;
1680     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1681       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1682     if (!isunix || !filespec.dsc$a_pointer)
1683       filespec.dsc$a_pointer = item;
1684     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1685     /*
1686      * Only return version specs, if the caller specified a version
1687      */
1688     had_version = strchr(item, ';');
1689     /*
1690      * Only return device and directory specs, if the caller specifed either.
1691      */
1692     had_device = strchr(item, ':');
1693     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1694
1695     while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1696                                  &defaultspec, 0, &status_value, &zero)))
1697         {
1698         char *string;
1699         char *c;
1700
1701         New(7005,string,resultspec.dsc$w_length+1,char);
1702         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1703         string[resultspec.dsc$w_length] = '\0';
1704         if (NULL == had_version)
1705             *((char *)strrchr(string, ';')) = '\0';
1706         if ((!had_directory) && (had_device == NULL))
1707             {
1708             if (NULL == (devdir = strrchr(string, ']')))
1709                 devdir = strrchr(string, '>');
1710             strcpy(string, devdir + 1);
1711             }
1712         /*
1713          * Be consistent with what the C RTL has already done to the rest of
1714          * the argv items and lowercase all of these names.
1715          */
1716         for (c = string; *c; ++c)
1717             if (isupper(*c))
1718                 *c = tolower(*c);
1719         if (isunix) trim_unixpath(item,string);
1720         add_item(head, tail, string, count);
1721         ++expcount;
1722         }
1723     if (expcount == 0)
1724         add_item(head, tail, item, count);
1725     lib$sfree1_dd(&resultspec);
1726     lib$find_file_end(&context);
1727 }
1728
1729 static int child_st[2];/* Event Flag set when child process completes   */
1730
1731 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
1732
1733 static unsigned long int exit_handler(int *status)
1734 {
1735 short iosb[4];
1736
1737     if (0 == child_st[0])
1738         {
1739 #ifdef ARGPROC_DEBUG
1740         fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1741 #endif
1742         fflush(stdout);     /* Have to flush pipe for binary data to    */
1743                             /* terminate properly -- <tp@mccall.com>    */
1744         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1745         sys$dassgn(child_chan);
1746         fclose(stdout);
1747         sys$synch(0, child_st);
1748         }
1749     return(1);
1750 }
1751
1752 static void sig_child(int chan)
1753 {
1754 #ifdef ARGPROC_DEBUG
1755     fprintf(stderr, "Child Completion AST\n");
1756 #endif
1757     if (child_st[0] == 0)
1758         child_st[0] = 1;
1759 }
1760
1761 static struct exit_control_block exit_block =
1762     {
1763     0,
1764     exit_handler,
1765     1,
1766     &exit_block.exit_status,
1767     0
1768     };
1769
1770 static void pipe_and_fork(char **cmargv)
1771 {
1772     char subcmd[2048];
1773     $DESCRIPTOR(cmddsc, "");
1774     static char mbxname[64];
1775     $DESCRIPTOR(mbxdsc, mbxname);
1776     int pid, j;
1777     unsigned long int zero = 0, one = 1;
1778
1779     strcpy(subcmd, cmargv[0]);
1780     for (j = 1; NULL != cmargv[j]; ++j)
1781         {
1782         strcat(subcmd, " \"");
1783         strcat(subcmd, cmargv[j]);
1784         strcat(subcmd, "\"");
1785         }
1786     cmddsc.dsc$a_pointer = subcmd;
1787     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1788
1789         create_mbx(&child_chan,&mbxdsc);
1790 #ifdef ARGPROC_DEBUG
1791     fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1792     fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1793 #endif
1794     _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1795                                         0, &pid, child_st, &zero, sig_child,
1796                                         &child_chan));
1797 #ifdef ARGPROC_DEBUG
1798     fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1799 #endif
1800     sys$dclexh(&exit_block);
1801     if (NULL == freopen(mbxname, "wb", stdout))
1802         {
1803         fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1804         }
1805 }
1806
1807 static int background_process(int argc, char **argv)
1808 {
1809 char command[2048] = "$";
1810 $DESCRIPTOR(value, "");
1811 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1812 static $DESCRIPTOR(null, "NLA0:");
1813 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1814 char pidstring[80];
1815 $DESCRIPTOR(pidstr, "");
1816 int pid;
1817 unsigned long int flags = 17, one = 1, retsts;
1818
1819     strcat(command, argv[0]);
1820     while (--argc)
1821         {
1822         strcat(command, " \"");
1823         strcat(command, *(++argv));
1824         strcat(command, "\"");
1825         }
1826     value.dsc$a_pointer = command;
1827     value.dsc$w_length = strlen(value.dsc$a_pointer);
1828     _ckvmssts(lib$set_symbol(&cmd, &value));
1829     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1830     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1831         _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1832     }
1833     else {
1834         _ckvmssts(retsts);
1835     }
1836 #ifdef ARGPROC_DEBUG
1837     fprintf(stderr, "%s\n", command);
1838 #endif
1839     sprintf(pidstring, "%08X", pid);
1840     fprintf(stderr, "%s\n", pidstring);
1841     pidstr.dsc$a_pointer = pidstring;
1842     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1843     lib$set_symbol(&pidsymbol, &pidstr);
1844     return(SS$_NORMAL);
1845 }
1846 /*}}}*/
1847 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1848
1849 /* trim_unixpath()
1850  * Trim Unix-style prefix off filespec, so it looks like what a shell
1851  * glob expansion would return (i.e. from specified prefix on, not
1852  * full path).  Note that returned filespec is Unix-style, regardless
1853  * of whether input filespec was VMS-style or Unix-style.
1854  *
1855  * Returns !=0 on success, 0 on failure.
1856  */
1857 /*{{{int trim_unixpath(char *template, char *fspec)*/
1858 int
1859 trim_unixpath(char *template, char *fspec)
1860 {
1861   char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1862   register int tmplen;
1863
1864   if (strpbrk(fspec,"]>:") != NULL) {
1865     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1866     else base = unixified;
1867   }
1868   else base = fspec;
1869   for (cp2 = base; *cp2; cp2++) ;  /* Find end of filespec */
1870
1871   /* Find prefix to template consisting of path elements without wildcards */
1872   if ((cp1 = strpbrk(template,"*%?")) == NULL)
1873     for (cp1 = template; *cp1; cp1++) ;
1874   else while (cp1 >= template && *cp1 != '/') cp1--;
1875   if (cp1 == template) return 1;  /* Wildcard was up front - no prefix to clip */
1876   tmplen = cp1 - template;
1877
1878   /* Try to find template prefix on filespec */
1879   if (!memcmp(base,template,tmplen)) return 1;  /* Nothing before prefix - we're done */
1880   for (; cp2 - base > tmplen; base++) {
1881      if (*base != '/') continue;
1882      if (!memcmp(base + 1,template,tmplen)) break;
1883   }
1884   if (cp2 - base == tmplen) return 0;  /* Not there - not good */
1885   base++;  /* Move past leading '/' */
1886   /* Copy down remaining portion of filespec, including trailing NUL */
1887   memmove(fspec,base,cp2 - base + 1);
1888   return 1;
1889
1890 }  /* end of trim_unixpath() */
1891 /*}}}*/
1892
1893
1894 /*
1895  *  VMS readdir() routines.
1896  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1897  *  This code has no copyright.
1898  *
1899  *  21-Jul-1994  Charles Bailey  bailey@genetics.upenn.edu
1900  *  Minor modifications to original routines.
1901  */
1902
1903     /* Number of elements in vms_versions array */
1904 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
1905
1906 /*
1907  *  Open a directory, return a handle for later use.
1908  */
1909 /*{{{ DIR *opendir(char*name) */
1910 DIR *
1911 opendir(char *name)
1912 {
1913     DIR *dd;
1914     char dir[NAM$C_MAXRSS+1];
1915
1916     /* Get memory for the handle, and the pattern. */
1917     New(7006,dd,1,DIR);
1918     if (do_tovmspath(name,dir,0) == NULL) {
1919       Safefree((char *)dd);
1920       return(NULL);
1921     }
1922     New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1923
1924     /* Fill in the fields; mainly playing with the descriptor. */
1925     (void)sprintf(dd->pattern, "%s*.*",dir);
1926     dd->context = 0;
1927     dd->count = 0;
1928     dd->vms_wantversions = 0;
1929     dd->pat.dsc$a_pointer = dd->pattern;
1930     dd->pat.dsc$w_length = strlen(dd->pattern);
1931     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1932     dd->pat.dsc$b_class = DSC$K_CLASS_S;
1933
1934     return dd;
1935 }  /* end of opendir() */
1936 /*}}}*/
1937
1938 /*
1939  *  Set the flag to indicate we want versions or not.
1940  */
1941 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1942 void
1943 vmsreaddirversions(DIR *dd, int flag)
1944 {
1945     dd->vms_wantversions = flag;
1946 }
1947 /*}}}*/
1948
1949 /*
1950  *  Free up an opened directory.
1951  */
1952 /*{{{ void closedir(DIR *dd)*/
1953 void
1954 closedir(DIR *dd)
1955 {
1956     (void)lib$find_file_end(&dd->context);
1957     Safefree(dd->pattern);
1958     Safefree((char *)dd);
1959 }
1960 /*}}}*/
1961
1962 /*
1963  *  Collect all the version numbers for the current file.
1964  */
1965 static void
1966 collectversions(dd)
1967     DIR *dd;
1968 {
1969     struct dsc$descriptor_s     pat;
1970     struct dsc$descriptor_s     res;
1971     struct dirent *e;
1972     char *p, *text, buff[sizeof dd->entry.d_name];
1973     int i;
1974     unsigned long context, tmpsts;
1975
1976     /* Convenient shorthand. */
1977     e = &dd->entry;
1978
1979     /* Add the version wildcard, ignoring the "*.*" put on before */
1980     i = strlen(dd->pattern);
1981     New(7008,text,i + e->d_namlen + 3,char);
1982     (void)strcpy(text, dd->pattern);
1983     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1984
1985     /* Set up the pattern descriptor. */
1986     pat.dsc$a_pointer = text;
1987     pat.dsc$w_length = i + e->d_namlen - 1;
1988     pat.dsc$b_dtype = DSC$K_DTYPE_T;
1989     pat.dsc$b_class = DSC$K_CLASS_S;
1990
1991     /* Set up result descriptor. */
1992     res.dsc$a_pointer = buff;
1993     res.dsc$w_length = sizeof buff - 2;
1994     res.dsc$b_dtype = DSC$K_DTYPE_T;
1995     res.dsc$b_class = DSC$K_CLASS_S;
1996
1997     /* Read files, collecting versions. */
1998     for (context = 0, e->vms_verscount = 0;
1999          e->vms_verscount < VERSIZE(e);
2000          e->vms_verscount++) {
2001         tmpsts = lib$find_file(&pat, &res, &context);
2002         if (tmpsts == RMS$_NMF || context == 0) break;
2003         _ckvmssts(tmpsts);
2004         buff[sizeof buff - 1] = '\0';
2005         if ((p = strchr(buff, ';')))
2006             e->vms_versions[e->vms_verscount] = atoi(p + 1);
2007         else
2008             e->vms_versions[e->vms_verscount] = -1;
2009     }
2010
2011     _ckvmssts(lib$find_file_end(&context));
2012     Safefree(text);
2013
2014 }  /* end of collectversions() */
2015
2016 /*
2017  *  Read the next entry from the directory.
2018  */
2019 /*{{{ struct dirent *readdir(DIR *dd)*/
2020 struct dirent *
2021 readdir(DIR *dd)
2022 {
2023     struct dsc$descriptor_s     res;
2024     char *p, buff[sizeof dd->entry.d_name];
2025     unsigned long int tmpsts;
2026
2027     /* Set up result descriptor, and get next file. */
2028     res.dsc$a_pointer = buff;
2029     res.dsc$w_length = sizeof buff - 2;
2030     res.dsc$b_dtype = DSC$K_DTYPE_T;
2031     res.dsc$b_class = DSC$K_CLASS_S;
2032     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2033     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
2034     if (!(tmpsts & 1)) {
2035       set_vaxc_errno(tmpsts);
2036       switch (tmpsts) {
2037         case RMS$_PRV:
2038           set_errno(EACCES);
2039           break;
2040         case RMS$_DEV:
2041           set_errno(ENODEV);
2042           break;
2043         case RMS$_DIR:
2044           set_errno(ENOTDIR);
2045           break;
2046         case RMS$_FNF:
2047           set_errno(ENOENT);
2048           break;
2049         default:
2050           set_errno(EVMSERR);
2051       }
2052       return NULL;
2053     }
2054     dd->count++;
2055     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2056     buff[sizeof buff - 1] = '\0';
2057     for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2058     *p = '\0';
2059
2060     /* Skip any directory component and just copy the name. */
2061     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2062     else (void)strcpy(dd->entry.d_name, buff);
2063
2064     /* Clobber the version. */
2065     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2066
2067     dd->entry.d_namlen = strlen(dd->entry.d_name);
2068     dd->entry.vms_verscount = 0;
2069     if (dd->vms_wantversions) collectversions(dd);
2070     return &dd->entry;
2071
2072 }  /* end of readdir() */
2073 /*}}}*/
2074
2075 /*
2076  *  Return something that can be used in a seekdir later.
2077  */
2078 /*{{{ long telldir(DIR *dd)*/
2079 long
2080 telldir(DIR *dd)
2081 {
2082     return dd->count;
2083 }
2084 /*}}}*/
2085
2086 /*
2087  *  Return to a spot where we used to be.  Brute force.
2088  */
2089 /*{{{ void seekdir(DIR *dd,long count)*/
2090 void
2091 seekdir(DIR *dd, long count)
2092 {
2093     int vms_wantversions;
2094
2095     /* If we haven't done anything yet... */
2096     if (dd->count == 0)
2097         return;
2098
2099     /* Remember some state, and clear it. */
2100     vms_wantversions = dd->vms_wantversions;
2101     dd->vms_wantversions = 0;
2102     _ckvmssts(lib$find_file_end(&dd->context));
2103     dd->context = 0;
2104
2105     /* The increment is in readdir(). */
2106     for (dd->count = 0; dd->count < count; )
2107         (void)readdir(dd);
2108
2109     dd->vms_wantversions = vms_wantversions;
2110
2111 }  /* end of seekdir() */
2112 /*}}}*/
2113
2114 /* VMS subprocess management
2115  *
2116  * my_vfork() - just a vfork(), after setting a flag to record that
2117  * the current script is trying a Unix-style fork/exec.
2118  *
2119  * vms_do_aexec() and vms_do_exec() are called in response to the
2120  * perl 'exec' function.  If this follows a vfork call, then they
2121  * call out the the regular perl routines in doio.c which do an
2122  * execvp (for those who really want to try this under VMS).
2123  * Otherwise, they do exactly what the perl docs say exec should
2124  * do - terminate the current script and invoke a new command
2125  * (See below for notes on command syntax.)
2126  *
2127  * do_aspawn() and do_spawn() implement the VMS side of the perl
2128  * 'system' function.
2129  *
2130  * Note on command arguments to perl 'exec' and 'system': When handled
2131  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2132  * are concatenated to form a DCL command string.  If the first arg
2133  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2134  * the the command string is hrnded off to DCL directly.  Otherwise,
2135  * the first token of the command is taken as the filespec of an image
2136  * to run.  The filespec is expanded using a default type of '.EXE' and
2137  * the process defaults for device, directory, etc., and the resultant
2138  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2139  * the command string as parameters.  This is perhaps a bit compicated,
2140  * but I hope it will form a happy medium between what VMS folks expect
2141  * from lib$spawn and what Unix folks expect from exec.
2142  */
2143
2144 static int vfork_called;
2145
2146 /*{{{int my_vfork()*/
2147 int
2148 my_vfork()
2149 {
2150   vfork_called++;
2151   return vfork();
2152 }
2153 /*}}}*/
2154
2155
2156 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2157
2158 static void
2159 vms_execfree() {
2160   if (Cmd) {
2161     Safefree(Cmd);
2162     Cmd = Nullch;
2163   }
2164   if (VMScmd.dsc$a_pointer) {
2165     Safefree(VMScmd.dsc$a_pointer);
2166     VMScmd.dsc$w_length = 0;
2167     VMScmd.dsc$a_pointer = Nullch;
2168   }
2169 }
2170
2171 static char *
2172 setup_argstr(SV *really, SV **mark, SV **sp)
2173 {
2174   char *junk, *tmps = Nullch;
2175   register size_t cmdlen = 0;
2176   size_t rlen;
2177   register SV **idx;
2178
2179   idx = mark;
2180   if (really) {
2181     tmps = SvPV(really,rlen);
2182     if (*tmps) {
2183       cmdlen += rlen + 1;
2184       idx++;
2185     }
2186   }
2187
2188   for (idx++; idx <= sp; idx++) {
2189     if (*idx) {
2190       junk = SvPVx(*idx,rlen);
2191       cmdlen += rlen ? rlen + 1 : 0;
2192     }
2193   }
2194   New(401,Cmd,cmdlen+1,char);
2195
2196   if (tmps && *tmps) {
2197     strcpy(Cmd,tmps);
2198     mark++;
2199   }
2200   else *Cmd = '\0';
2201   while (++mark <= sp) {
2202     if (*mark) {
2203       strcat(Cmd," ");
2204       strcat(Cmd,SvPVx(*mark,na));
2205     }
2206   }
2207   return Cmd;
2208
2209 }  /* end of setup_argstr() */
2210
2211
2212 static unsigned long int
2213 setup_cmddsc(char *cmd, int check_img)
2214 {
2215   char resspec[NAM$C_MAXRSS+1];
2216   $DESCRIPTOR(defdsc,".EXE");
2217   $DESCRIPTOR(resdsc,resspec);
2218   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2219   unsigned long int cxt = 0, flags = 1, retsts;
2220   register char *s, *rest, *cp;
2221   register int isdcl = 0;
2222
2223   s = cmd;
2224   while (*s && isspace(*s)) s++;
2225   if (check_img) {
2226     if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2227       isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
2228       for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2229         if (*cp == ':' || *cp == '[' || *cp == '<') {
2230           isdcl = 0;
2231           break;
2232         }
2233       }
2234     }
2235   }
2236   else isdcl = 1;
2237   if (isdcl) {  /* It's a DCL command, just do it. */
2238     VMScmd.dsc$w_length = strlen(cmd);
2239     if (cmd == Cmd) {
2240        VMScmd.dsc$a_pointer = Cmd;
2241        Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
2242     }
2243     else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2244   }
2245   else {                           /* assume first token is an image spec */
2246     cmd = s;
2247     while (*s && !isspace(*s)) s++;
2248     rest = *s ? s : 0;
2249     imgdsc.dsc$a_pointer = cmd;
2250     imgdsc.dsc$w_length = s - cmd;
2251     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2252     if (!(retsts & 1)) {
2253       /* just hand off status values likely to be due to user error */
2254       if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2255           retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2256          (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2257       else { _ckvmssts(retsts); }
2258     }
2259     else {
2260       _ckvmssts(lib$find_file_end(&cxt));
2261       s = resspec;
2262       while (*s && !isspace(*s)) s++;
2263       *s = '\0';
2264       New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2265       strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2266       strcat(VMScmd.dsc$a_pointer,resspec);
2267       if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2268       VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2269     }
2270   }
2271
2272   return SS$_NORMAL;
2273 }  /* end of setup_cmddsc() */
2274
2275 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2276 bool
2277 vms_do_aexec(SV *really,SV **mark,SV **sp)
2278 {
2279   if (sp > mark) {
2280     if (vfork_called) {           /* this follows a vfork - act Unixish */
2281       vfork_called--;
2282       if (vfork_called < 0) {
2283         warn("Internal inconsistency in tracking vforks");
2284         vfork_called = 0;
2285       }
2286       else return do_aexec(really,mark,sp);
2287     }
2288                                            /* no vfork - act VMSish */
2289     return vms_do_exec(setup_argstr(really,mark,sp));
2290
2291   }
2292
2293   return FALSE;
2294 }  /* end of vms_do_aexec() */
2295 /*}}}*/
2296
2297 /* {{{bool vms_do_exec(char *cmd) */
2298 bool
2299 vms_do_exec(char *cmd)
2300 {
2301
2302   if (vfork_called) {             /* this follows a vfork - act Unixish */
2303     vfork_called--;
2304     if (vfork_called < 0) {
2305       warn("Internal inconsistency in tracking vforks");
2306       vfork_called = 0;
2307     }
2308     else return do_exec(cmd);
2309   }
2310
2311   {                               /* no vfork - act VMSish */
2312     unsigned long int retsts;
2313
2314     if ((retsts = setup_cmddsc(cmd,1)) & 1)
2315       retsts = lib$do_command(&VMScmd);
2316
2317     set_errno(EVMSERR);
2318     set_vaxc_errno(retsts);
2319     if (dowarn)
2320       warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2321     vms_execfree();
2322   }
2323
2324   return FALSE;
2325
2326 }  /* end of vms_do_exec() */
2327 /*}}}*/
2328
2329 unsigned long int do_spawn(char *);
2330
2331 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2332 unsigned long int
2333 do_aspawn(SV *really,SV **mark,SV **sp)
2334 {
2335   if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2336
2337   return SS$_ABORT;
2338 }  /* end of do_aspawn() */
2339 /*}}}*/
2340
2341 /* {{{unsigned long int do_spawn(char *cmd) */
2342 unsigned long int
2343 do_spawn(char *cmd)
2344 {
2345   unsigned long int substs, hadcmd = 1;
2346
2347   if (!cmd || !*cmd) {
2348     hadcmd = 0;
2349     _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2350   }
2351   else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2352     _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2353   }
2354
2355   if (!(substs&1)) {
2356     set_errno(EVMSERR);
2357     set_vaxc_errno(substs);
2358     if (dowarn)
2359       warn("Can't exec \"%s\": %s",
2360            hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2361   }
2362   vms_execfree();
2363   return substs;
2364
2365 }  /* end of do_spawn() */
2366 /*}}}*/
2367
2368 /*
2369  * A simple fwrite replacement which outputs itmsz*nitm chars without
2370  * introducing record boundaries every itmsz chars.
2371  */
2372 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2373 int
2374 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2375 {
2376   register char *cp, *end;
2377
2378   end = (char *)src + itmsz * nitm;
2379
2380   while ((char *)src <= end) {
2381     for (cp = src; cp <= end; cp++) if (!*cp) break;
2382     if (fputs(src,dest) == EOF) return EOF;
2383     if (cp < end)
2384       if (fputc('\0',dest) == EOF) return EOF;
2385     src = cp + 1;
2386   }
2387
2388   return 1;
2389
2390 }  /* end of my_fwrite() */
2391 /*}}}*/
2392
2393 /*
2394  * Here are replacements for the following Unix routines in the VMS environment:
2395  *      getpwuid    Get information for a particular UIC or UID
2396  *      getpwnam    Get information for a named user
2397  *      getpwent    Get information for each user in the rights database
2398  *      setpwent    Reset search to the start of the rights database
2399  *      endpwent    Finish searching for users in the rights database
2400  *
2401  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2402  * (defined in pwd.h), which contains the following fields:-
2403  *      struct passwd {
2404  *              char        *pw_name;    Username (in lower case)
2405  *              char        *pw_passwd;  Hashed password
2406  *              unsigned int pw_uid;     UIC
2407  *              unsigned int pw_gid;     UIC group  number
2408  *              char        *pw_unixdir; Default device/directory (VMS-style)
2409  *              char        *pw_gecos;   Owner name
2410  *              char        *pw_dir;     Default device/directory (Unix-style)
2411  *              char        *pw_shell;   Default CLI name (eg. DCL)
2412  *      };
2413  * If the specified user does not exist, getpwuid and getpwnam return NULL.
2414  *
2415  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2416  * not the UIC member number (eg. what's returned by getuid()),
2417  * getpwuid() can accept either as input (if uid is specified, the caller's
2418  * UIC group is used), though it won't recognise gid=0.
2419  *
2420  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2421  * information about other users in your group or in other groups, respectively.
2422  * If the required privilege is not available, then these routines fill only
2423  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2424  * string).
2425  *
2426  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2427  */
2428
2429 /* sizes of various UAF record fields */
2430 #define UAI$S_USERNAME 12
2431 #define UAI$S_IDENT    31
2432 #define UAI$S_OWNER    31
2433 #define UAI$S_DEFDEV   31
2434 #define UAI$S_DEFDIR   63
2435 #define UAI$S_DEFCLI   31
2436 #define UAI$S_PWD       8
2437
2438 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
2439                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2440                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
2441
2442 static char __empty[]= "";
2443 static struct passwd __passwd_empty=
2444     {(char *) __empty, (char *) __empty, 0, 0,
2445      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2446 static int contxt= 0;
2447 static struct passwd __pwdcache;
2448 static char __pw_namecache[UAI$S_IDENT+1];
2449
2450 static char *_mystrtolower(char *str)
2451 {
2452   if (str) for (; *str; ++str) *str= tolower(*str);
2453   return str;
2454 }
2455
2456 /*
2457  * This routine does most of the work extracting the user information.
2458  */
2459 static int fillpasswd (const char *name, struct passwd *pwd)
2460 {
2461     static struct {
2462         unsigned char length;
2463         char pw_gecos[UAI$S_OWNER+1];
2464     } owner;
2465     static union uicdef uic;
2466     static struct {
2467         unsigned char length;
2468         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2469     } defdev;
2470     static struct {
2471         unsigned char length;
2472         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2473     } defdir;
2474     static struct {
2475         unsigned char length;
2476         char pw_shell[UAI$S_DEFCLI+1];
2477     } defcli;
2478     static char pw_passwd[UAI$S_PWD+1];
2479
2480     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2481     struct dsc$descriptor_s name_desc;
2482     int status;
2483
2484     static struct itmlst_3 itmlst[]= {
2485         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
2486         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
2487         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
2488         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
2489         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
2490         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
2491         {0,                0,           NULL,    NULL}};
2492
2493     name_desc.dsc$w_length=  strlen(name);
2494     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2495     name_desc.dsc$b_class=   DSC$K_CLASS_S;
2496     name_desc.dsc$a_pointer= (char *) name;
2497
2498 /*  Note that sys$getuai returns many fields as counted strings. */
2499     status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2500     if (!(status&1)) return status;
2501
2502     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
2503     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2504     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2505     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2506     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2507     owner.pw_gecos[lowner]=            '\0';
2508     defdev.pw_dir[ldefdev+ldefdir]= '\0';
2509     defcli.pw_shell[ldefcli]=          '\0';
2510     if (valid_uic(uic)) {
2511         pwd->pw_uid= uic.uic$l_uic;
2512         pwd->pw_gid= uic.uic$v_group;
2513     }
2514     else
2515       warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2516     pwd->pw_passwd=  pw_passwd;
2517     pwd->pw_gecos=   owner.pw_gecos;
2518     pwd->pw_dir=     defdev.pw_dir;
2519     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2520     pwd->pw_shell=   defcli.pw_shell;
2521     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2522         int ldir;
2523         ldir= strlen(pwd->pw_unixdir) - 1;
2524         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2525     }
2526     else
2527         strcpy(pwd->pw_unixdir, pwd->pw_dir);
2528     _mystrtolower(pwd->pw_unixdir);
2529     return status;
2530 }
2531
2532 /*
2533  * Get information for a named user.
2534 */
2535 /*{{{struct passwd *getpwnam(char *name)*/
2536 struct passwd *my_getpwnam(char *name)
2537 {
2538     struct dsc$descriptor_s name_desc;
2539     union uicdef uic;
2540     unsigned long int status, stat;
2541
2542     __pwdcache = __passwd_empty;
2543     if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
2544         || status == SS$_NOGRPPRV  || status == RMS$_RNF) {
2545       /* We still may be able to determine pw_uid and pw_gid */
2546       name_desc.dsc$w_length=  strlen(name);
2547       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2548       name_desc.dsc$b_class=   DSC$K_CLASS_S;
2549       name_desc.dsc$a_pointer= (char *) name;
2550       if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2551         __pwdcache.pw_uid= uic.uic$l_uic;
2552         __pwdcache.pw_gid= uic.uic$v_group;
2553       }
2554       else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
2555       else { _ckvmssts(stat); }
2556     }
2557     else { _ckvmssts(status); }
2558     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2559     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2560     __pwdcache.pw_name= __pw_namecache;
2561     return &__pwdcache;
2562 }  /* end of my_getpwnam() */
2563 /*}}}*/
2564
2565 /*
2566  * Get information for a particular UIC or UID.
2567  * Called by my_getpwent with uid=-1 to list all users.
2568 */
2569 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2570 struct passwd *my_getpwuid(Uid_t uid)
2571 {
2572     const $DESCRIPTOR(name_desc,__pw_namecache);
2573     unsigned short lname;
2574     union uicdef uic;
2575     unsigned long int status;
2576
2577     if (uid == (unsigned int) -1) {
2578       do {
2579         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2580         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2581           my_endpwent();
2582           return NULL;
2583         }
2584         else { _ckvmssts(status); }
2585       } while (!valid_uic (uic));
2586     }
2587     else {
2588       uic.uic$l_uic= uid;
2589       if (!uic.uic$v_group) uic.uic$v_group= getgid();
2590       if (valid_uic(uic))
2591         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2592       else status = SS$_IVIDENT;
2593       _ckvmssts(status);
2594     }
2595     __pw_namecache[lname]= '\0';
2596     _mystrtolower(__pw_namecache);
2597
2598     __pwdcache = __passwd_empty;
2599     __pwdcache.pw_name = __pw_namecache;
2600
2601 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2602     The identifier's value is usually the UIC, but it doesn't have to be,
2603     so if we can, we let fillpasswd update this. */
2604     __pwdcache.pw_uid =  uic.uic$l_uic;
2605     __pwdcache.pw_gid =  uic.uic$v_group;
2606
2607     status = fillpasswd(__pw_namecache, &__pwdcache);
2608     if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
2609         status != RMS$_RNF) { _ckvmssts(status); }
2610     return &__pwdcache;
2611
2612 }  /* end of my_getpwuid() */
2613 /*}}}*/
2614
2615 /*
2616  * Get information for next user.
2617 */
2618 /*{{{struct passwd *my_getpwent()*/
2619 struct passwd *my_getpwent()
2620 {
2621     return (my_getpwuid((unsigned int) -1));
2622 }
2623 /*}}}*/
2624
2625 /*
2626  * Finish searching rights database for users.
2627 */
2628 /*{{{void my_endpwent()*/
2629 void my_endpwent()
2630 {
2631     if (contxt) {
2632       _ckvmssts(sys$finish_rdb(&contxt));
2633       contxt= 0;
2634     }
2635 }
2636 /*}}}*/
2637
2638
2639 /* my_gmtime
2640  * If the CRTL has a real gmtime(), use it, else look for the logical
2641  * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2642  * VMS >= 6.0.  Can be manually defined under earlier versions of VMS
2643  * to translate to the number of seconds which must be added to UTC
2644  * to get to the local time of the system.
2645  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
2646  */
2647
2648 /*{{{struct tm *my_gmtime(const time_t *time)*/
2649 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h.  #undef it here
2650  * so we can call the CRTL's routine to see if it works.
2651  */
2652 #undef gmtime
2653 struct tm *
2654 my_gmtime(const time_t *time)
2655 {
2656   static int gmtime_emulation_type;
2657   static time_t utc_offset_secs;
2658   char *p;
2659   time_t when;
2660
2661   if (gmtime_emulation_type == 0) {
2662     gmtime_emulation_type++;
2663     when = 300000000;
2664     if (gmtime(&when) == NULL) {  /* CRTL gmtime() is just a stub */
2665       gmtime_emulation_type++;
2666       if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2667         gmtime_emulation_type++;
2668       else
2669         utc_offset_secs = (time_t) atol(p);
2670     }
2671   }
2672
2673   switch (gmtime_emulation_type) {
2674     case 1:
2675       return gmtime(time);
2676     case 2:
2677       when = *time - utc_offset_secs;
2678       return localtime(&when);
2679     default:
2680       warn("gmtime not supported on this system");
2681       return NULL;
2682   }
2683 }  /* end of my_gmtime() */
2684 /* Reset definition for later calls */
2685 #define gmtime(t) my_gmtime(t)
2686 /*}}}*/
2687
2688
2689 /*
2690  * flex_stat, flex_fstat
2691  * basic stat, but gets it right when asked to stat
2692  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2693  */
2694
2695 /* encode_dev packs a VMS device name string into an integer to allow
2696  * simple comparisons. This can be used, for example, to check whether two
2697  * files are located on the same device, by comparing their encoded device
2698  * names. Even a string comparison would not do, because stat() reuses the
2699  * device name buffer for each call; so without encode_dev, it would be
2700  * necessary to save the buffer and use strcmp (this would mean a number of
2701  * changes to the standard Perl code, to say nothing of what a Perl script
2702  * would have to do.
2703  *
2704  * The device lock id, if it exists, should be unique (unless perhaps compared
2705  * with lock ids transferred from other nodes). We have a lock id if the disk is
2706  * mounted cluster-wide, which is when we tend to get long (host-qualified)
2707  * device names. Thus we use the lock id in preference, and only if that isn't
2708  * available, do we try to pack the device name into an integer (flagged by
2709  * the sign bit (LOCKID_MASK) being set).
2710  *
2711  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2712  * name and its encoded form, but it seems very unlikely that we will find
2713  * two files on different disks that share the same encoded device names,
2714  * and even more remote that they will share the same file id (if the test
2715  * is to check for the same file).
2716  *
2717  * A better method might be to use sys$device_scan on the first call, and to
2718  * search for the device, returning an index into the cached array.
2719  * The number returned would be more intelligable.
2720  * This is probably not worth it, and anyway would take quite a bit longer
2721  * on the first call.
2722  */
2723 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
2724 static dev_t encode_dev (const char *dev)
2725 {
2726   int i;
2727   unsigned long int f;
2728   dev_t enc;
2729   char c;
2730   const char *q;
2731
2732   if (!dev || !dev[0]) return 0;
2733
2734 #if LOCKID_MASK
2735   {
2736     struct dsc$descriptor_s dev_desc;
2737     unsigned long int status, lockid, item = DVI$_LOCKID;
2738
2739     /* For cluster-mounted disks, the disk lock identifier is unique, so we
2740        can try that first. */
2741     dev_desc.dsc$w_length =  strlen (dev);
2742     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
2743     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
2744     dev_desc.dsc$a_pointer = (char *) dev;
2745     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2746     if (lockid) return (lockid & ~LOCKID_MASK);
2747   }
2748 #endif
2749
2750   /* Otherwise we try to encode the device name */
2751   enc = 0;
2752   f = 1;
2753   i = 0;
2754   for (q = dev + strlen(dev); q--; q >= dev) {
2755     if (isdigit (*q))
2756       c= (*q) - '0';
2757     else if (isalpha (toupper (*q)))
2758       c= toupper (*q) - 'A' + (char)10;
2759     else
2760       continue; /* Skip '$'s */
2761     i++;
2762     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
2763     if (i>1) f *= 36;
2764     enc += f * (unsigned long int) c;
2765   }
2766   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
2767
2768 }  /* end of encode_dev() */
2769
2770 static char namecache[NAM$C_MAXRSS+1];
2771
2772 static int
2773 is_null_device(name)
2774     const char *name;
2775 {
2776     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2777        The underscore prefix, controller letter, and unit number are
2778        independently optional; for our purposes, the colon punctuation
2779        is not.  The colon can be trailed by optional directory and/or
2780        filename, but two consecutive colons indicates a nodename rather
2781        than a device.  [pr]  */
2782   if (*name == '_') ++name;
2783   if (tolower(*name++) != 'n') return 0;
2784   if (tolower(*name++) != 'l') return 0;
2785   if (tolower(*name) == 'a') ++name;
2786   if (*name == '0') ++name;
2787   return (*name++ == ':') && (*name != ':');
2788 }
2789
2790 /* Do the permissions allow some operation?  Assumes statcache already set. */
2791 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2792  * subset of the applicable information.
2793  */
2794 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2795 I32
2796 cando(I32 bit, I32 effective, struct stat *statbufp)
2797 {
2798   if (statbufp == &statcache)
2799     return cando_by_name(bit,effective,namecache);
2800   else {
2801     char fname[NAM$C_MAXRSS+1];
2802     unsigned long int retsts;
2803     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2804                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2805
2806     /* If the struct mystat is stale, we're OOL; stat() overwrites the
2807        device name on successive calls */
2808     devdsc.dsc$a_pointer = statbufp->st_devnam;
2809     devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2810     namdsc.dsc$a_pointer = fname;
2811     namdsc.dsc$w_length = sizeof fname - 1;
2812
2813     retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
2814                              &namdsc.dsc$w_length,0,0);
2815     if (retsts & 1) {
2816       fname[namdsc.dsc$w_length] = '\0';
2817       return cando_by_name(bit,effective,fname);
2818     }
2819     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2820       warn("Can't get filespec - stale stat buffer?\n");
2821       return FALSE;
2822     }
2823     _ckvmssts(retsts);
2824     return FALSE;  /* Should never get to here */
2825   }
2826 }  /* end of cando() */
2827 /*}}}*/
2828
2829 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2830 I32
2831 cando_by_name(I32 bit, I32 effective, char *fname)
2832 {
2833   static char usrname[L_cuserid];
2834   static struct dsc$descriptor_s usrdsc =
2835          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2836
2837   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2838   unsigned short int retlen;
2839   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2840   union prvdef curprv;
2841   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2842          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2843   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2844          {0,0,0,0}};
2845
2846   if (!fname || !*fname) return FALSE;
2847   if (!usrdsc.dsc$w_length) {
2848     cuserid(usrname);
2849     usrdsc.dsc$w_length = strlen(usrname);
2850   }
2851   namdsc.dsc$w_length = strlen(fname);
2852   namdsc.dsc$a_pointer = fname;
2853   switch (bit) {
2854     case S_IXUSR:
2855     case S_IXGRP:
2856     case S_IXOTH:
2857       access = ARM$M_EXECUTE;
2858       break;
2859     case S_IRUSR:
2860     case S_IRGRP:
2861     case S_IROTH:
2862       access = ARM$M_READ;
2863       break;
2864     case S_IWUSR:
2865     case S_IWGRP:
2866     case S_IWOTH:
2867       access = ARM$M_WRITE;
2868       break;
2869     case S_IDUSR:
2870     case S_IDGRP:
2871     case S_IDOTH:
2872       access = ARM$M_DELETE;
2873       break;
2874     default:
2875       return FALSE;
2876   }
2877
2878   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
2879   if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
2880       retsts == RMS$_DIR   || retsts == RMS$_DEV) return FALSE;
2881   if (retsts == SS$_NORMAL) {
2882     if (!privused) return TRUE;
2883     /* We can get access, but only by using privs.  Do we have the
2884        necessary privs currently enabled? */
2885     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
2886     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
2887     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv
2888                                   &&  !curprv.prv$v_bypass)  return FALSE;
2889     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv
2890          && !curprv.prv$v_sysprv  &&  !curprv.prv$v_bypass)  return FALSE;
2891     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
2892     return TRUE;
2893   }
2894   _ckvmssts(retsts);
2895
2896   return FALSE;  /* Should never get here */
2897
2898 }  /* end of cando_by_name() */
2899 /*}}}*/
2900
2901
2902 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
2903 int
2904 flex_fstat(int fd, struct stat *statbuf)
2905 {
2906   char fspec[NAM$C_MAXRSS+1];
2907
2908   if (!getname(fd,fspec,1)) return -1;
2909   return flex_stat(fspec,statbuf);
2910
2911 }  /* end of flex_fstat() */
2912 /*}}}*/
2913
2914 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
2915 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
2916  * 'struct stat' elsewhere in Perl would use our struct.  We go back
2917  * to the system version here, since we're actually calling their
2918  * stat().
2919  */
2920 #undef stat
2921 int
2922 flex_stat(char *fspec, struct mystat *statbufp)
2923 {
2924     char fileified[NAM$C_MAXRSS+1];
2925     int retval,myretval;
2926     struct mystat tmpbuf;
2927
2928
2929     if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
2930     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2931       memset(statbufp,0,sizeof *statbufp);
2932       statbufp->st_dev = encode_dev("_NLA0:");
2933       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
2934       statbufp->st_uid = 0x00010001;
2935       statbufp->st_gid = 0x0001;
2936       time((time_t *)&statbufp->st_mtime);
2937       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
2938       return 0;
2939     }
2940
2941     if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
2942     else {
2943       myretval = stat(fileified,(stat_t *) &tmpbuf);
2944     }
2945     retval = stat(fspec,(stat_t *) statbufp);
2946     if (!myretval) {
2947       if (retval == -1) {
2948         *statbufp = tmpbuf;
2949         retval = 0;
2950       }
2951       else if (!retval) { /* Dir with same name.  Substitute it. */
2952         statbufp->st_mode &= ~S_IFDIR;
2953         statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
2954         strcpy(namecache,fileified);
2955       }
2956     }
2957     if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
2958     return retval;
2959
2960 }  /* end of flex_stat() */
2961 /* Reset definition for later calls */
2962 #define stat mystat
2963 /*}}}*/
2964
2965 /***  The following glue provides 'hooks' to make some of the routines
2966  * from this file available from Perl.  These routines are sufficiently
2967  * basic, and are required sufficiently early in the build process,
2968  * that's it's nice to have them available to miniperl as well as the
2969  * full Perl, so they're set up here instead of in an extension.  The
2970  * Perl code which handles importation of these names into a given
2971  * package lives in [.VMS]Filespec.pm in @INC.
2972  */
2973
2974 void
2975 vmsify_fromperl(CV *cv)
2976 {
2977   dXSARGS;
2978   char *vmsified;
2979
2980   if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
2981   vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
2982   ST(0) = sv_newmortal();
2983   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
2984   XSRETURN(1);
2985 }
2986
2987 void
2988 unixify_fromperl(CV *cv)
2989 {
2990   dXSARGS;
2991   char *unixified;
2992
2993   if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
2994   unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
2995   ST(0) = sv_newmortal();
2996   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
2997   XSRETURN(1);
2998 }
2999
3000 void
3001 fileify_fromperl(CV *cv)
3002 {
3003   dXSARGS;
3004   char *fileified;
3005
3006   if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3007   fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3008   ST(0) = sv_newmortal();
3009   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3010   XSRETURN(1);
3011 }
3012
3013 void
3014 pathify_fromperl(CV *cv)
3015 {
3016   dXSARGS;
3017   char *pathified;
3018
3019   if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3020   pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3021   ST(0) = sv_newmortal();
3022   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3023   XSRETURN(1);
3024 }
3025
3026 void
3027 vmspath_fromperl(CV *cv)
3028 {
3029   dXSARGS;
3030   char *vmspath;
3031
3032   if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3033   vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3034   ST(0) = sv_newmortal();
3035   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3036   XSRETURN(1);
3037 }
3038
3039 void
3040 unixpath_fromperl(CV *cv)
3041 {
3042   dXSARGS;
3043   char *unixpath;
3044
3045   if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3046   unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3047   ST(0) = sv_newmortal();
3048   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3049   XSRETURN(1);
3050 }
3051
3052 void
3053 candelete_fromperl(CV *cv)
3054 {
3055   dXSARGS;
3056   char vmsspec[NAM$C_MAXRSS+1];
3057
3058   if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3059   if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
3060     ST(0) = &sv_yes;
3061   else ST(0) = &sv_no;
3062   XSRETURN(1);
3063 }
3064
3065 void
3066 init_os_extras()
3067 {
3068   char* file = __FILE__;
3069
3070   newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
3071   newXS("VMS::Filespec::unixify",unixify_fromperl,file);
3072   newXS("VMS::Filespec::pathify",pathify_fromperl,file);
3073   newXS("VMS::Filespec::fileify",fileify_fromperl,file);
3074   newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
3075   newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
3076   newXS("VMS::Filespec::candelete",candelete_fromperl,file);
3077   return;
3078 }
3079
3080 /*  End of vms.c */