vms/vms.c

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