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