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