vms/vms.c

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