source: trunk/third/perl/vms/vms.c @ 17035

Revision 17035, 212.9 KB checked in by zacheiss, 23 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r17034, which included commits to RCS files with non-trunk default branches.
Line 
1/* vms.c
2 *
3 * VMS-specific routines for perl5
4 * Version: 5.7.0
5 *
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 *             and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
10 */
11
12#include <acedef.h>
13#include <acldef.h>
14#include <armdef.h>
15#include <atrdef.h>
16#include <chpdef.h>
17#include <clidef.h>
18#include <climsgdef.h>
19#include <descrip.h>
20#include <devdef.h>
21#include <dvidef.h>
22#include <fibdef.h>
23#include <float.h>
24#include <fscndef.h>
25#include <iodef.h>
26#include <jpidef.h>
27#include <kgbdef.h>
28#include <libclidef.h>
29#include <libdef.h>
30#include <lib$routines.h>
31#include <lnmdef.h>
32#include <prvdef.h>
33#include <psldef.h>
34#include <rms.h>
35#include <shrdef.h>
36#include <ssdef.h>
37#include <starlet.h>
38#include <strdef.h>
39#include <str$routines.h>
40#include <syidef.h>
41#include <uaidef.h>
42#include <uicdef.h>
43
44/* Older versions of ssdef.h don't have these */
45#ifndef SS$_INVFILFOROP
46#  define SS$_INVFILFOROP 3930
47#endif
48#ifndef SS$_NOSUCHOBJECT
49#  define SS$_NOSUCHOBJECT 2696
50#endif
51
52/* Don't replace system definitions of vfork, getenv, and stat,
53 * code below needs to get to the underlying CRTL routines. */
54#define DONT_MASK_RTL_CALLS
55#include "EXTERN.h"
56#include "perl.h"
57#include "XSUB.h"
58/* Anticipating future expansion in lexical warnings . . . */
59#ifndef WARN_INTERNAL
60#  define WARN_INTERNAL WARN_MISC
61#endif
62
63#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
64#  define RTL_USES_UTC 1
65#endif
66
67
68/* gcc's header files don't #define direct access macros
69 * corresponding to VAXC's variant structs */
70#ifdef __GNUC__
71#  define uic$v_format uic$r_uic_form.uic$v_format
72#  define uic$v_group uic$r_uic_form.uic$v_group
73#  define uic$v_member uic$r_uic_form.uic$v_member
74#  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
75#  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
76#  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
77#  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
78#endif
79
80#if defined(NEED_AN_H_ERRNO)
81dEXT int h_errno;
82#endif
83
84struct itmlst_3 {
85  unsigned short int buflen;
86  unsigned short int itmcode;
87  void *bufadr;
88  unsigned short int *retlen;
89};
90
91#define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
92#define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
93#define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
94#define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
95#define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
96#define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
97#define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
98#define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
99#define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
100
101/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
102#define PERL_LNM_MAX_ALLOWED_INDEX 127
103
104static char *__mystrtolower(char *str)
105{
106  if (str) for (; *str; ++str) *str= tolower(*str);
107  return str;
108}
109
110static struct dsc$descriptor_s fildevdsc =
111  { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
112static struct dsc$descriptor_s crtlenvdsc =
113  { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
114static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
115static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
116static struct dsc$descriptor_s **env_tables = defenv;
117static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
118
119/* True if we shouldn't treat barewords as logicals during directory */
120/* munching */
121static int no_translate_barewords;
122
123/* Temp for subprocess commands */
124static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
125
126#ifndef RTL_USES_UTC
127static int tz_updated = 1;
128#endif
129
130/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
131int
132Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
133  struct dsc$descriptor_s **tabvec, unsigned long int flags)
134{
135    char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
136    unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
137    unsigned long int retsts, attr = LNM$M_CASE_BLIND;
138    unsigned char acmode;
139    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
140                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
141    struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
142                                 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
143                                 {0, 0, 0, 0}};
144    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
145#if defined(USE_THREADS)
146    /* We jump through these hoops because we can be called at */
147    /* platform-specific initialization time, which is before anything is */
148    /* set up--we can't even do a plain dTHX since that relies on the */
149    /* interpreter structure to be initialized */
150    struct perl_thread *thr;
151    if (PL_curinterp) {
152      thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
153    } else {
154      thr = NULL;
155    }
156#endif
157
158    if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
159      set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
160    }
161    for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
162      *cp2 = _toupper(*cp1);
163      if (cp1 - lnm > LNM$C_NAMLENGTH) {
164        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
165        return 0;
166      }
167    }
168    lnmdsc.dsc$w_length = cp1 - lnm;
169    lnmdsc.dsc$a_pointer = uplnm;
170    uplnm[lnmdsc.dsc$w_length] = '\0';
171    secure = flags & PERL__TRNENV_SECURE;
172    acmode = secure ? PSL$C_EXEC : PSL$C_USER;
173    if (!tabvec || !*tabvec) tabvec = env_tables;
174
175    for (curtab = 0; tabvec[curtab]; curtab++) {
176      if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
177        if (!ivenv && !secure) {
178          char *eq, *end;
179          int i;
180          if (!environ) {
181            ivenv = 1;
182            Perl_warn(aTHX_ "Can't read CRTL environ\n");
183            continue;
184          }
185          retsts = SS$_NOLOGNAM;
186          for (i = 0; environ[i]; i++) {
187            if ((eq = strchr(environ[i],'=')) &&
188                !strncmp(environ[i],uplnm,eq - environ[i])) {
189              eq++;
190              for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
191              if (!eqvlen) continue;
192              retsts = SS$_NORMAL;
193              break;
194            }
195          }
196          if (retsts != SS$_NOLOGNAM) break;
197        }
198      }
199      else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
200               !str$case_blind_compare(&tmpdsc,&clisym)) {
201        if (!ivsym && !secure) {
202          unsigned short int deflen = LNM$C_NAMLENGTH;
203          struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
204          /* dynamic dsc to accomodate possible long value */
205          _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
206          retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
207          if (retsts & 1) {
208            if (eqvlen > 1024) {
209              set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
210              eqvlen = 1024;
211              /* Special hack--we might be called before the interpreter's */
212              /* fully initialized, in which case either thr or PL_curcop */
213              /* might be bogus. We have to check, since ckWARN needs them */
214              /* both to be valid if running threaded */
215#if defined(USE_THREADS)
216              if (thr && PL_curcop) {
217#endif
218                if (ckWARN(WARN_MISC)) {
219                  Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
220                }
221#if defined(USE_THREADS)
222              } else {
223                  Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
224              }
225#endif
226             
227            }
228            strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
229          }
230          _ckvmssts(lib$sfree1_dd(&eqvdsc));
231          if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
232          if (retsts == LIB$_NOSUCHSYM) continue;
233          break;
234        }
235      }
236      else if (!ivlnm) {
237        retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
238        if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
239        if (retsts == SS$_NOLOGNAM) continue;
240        /* PPFs have a prefix */
241        if (
242#if INTSIZE == 4
243             *((int *)uplnm) == *((int *)"SYS$")                    &&
244#endif
245             eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
246             ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
247               (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
248               (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
249               (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
250          memcpy(eqv,eqv+4,eqvlen-4);
251          eqvlen -= 4;
252        }
253        break;
254      }
255    }
256    if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
257    else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
258             retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
259             retsts == SS$_NOLOGNAM) {
260      set_errno(EINVAL);  set_vaxc_errno(retsts);
261    }
262    else _ckvmssts(retsts);
263    return 0;
264}  /* end of vmstrnenv */
265/*}}}*/
266
267/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
268/* Define as a function so we can access statics. */
269int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
270{
271  return vmstrnenv(lnm,eqv,idx,fildev,                                   
272#ifdef SECURE_INTERNAL_GETENV
273                   (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
274#else
275                   0
276#endif
277                                                                              );
278}
279/*}}}*/
280
281/* my_getenv
282 * Note: Uses Perl temp to store result so char * can be returned to
283 * caller; this pointer will be invalidated at next Perl statement
284 * transition.
285 * We define this as a function rather than a macro in terms of my_getenv_len()
286 * so that it'll work when PL_curinterp is undefined (and we therefore can't
287 * allocate SVs).
288 */
289/*{{{ char *my_getenv(const char *lnm, bool sys)*/
290char *
291Perl_my_getenv(pTHX_ const char *lnm, bool sys)
292{
293    static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
294    char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
295    unsigned long int idx = 0;
296    int trnsuccess, success, secure, saverr, savvmserr;
297    SV *tmpsv;
298
299    if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
300      /* Set up a temporary buffer for the return value; Perl will
301       * clean it up at the next statement transition */
302      tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
303      if (!tmpsv) return NULL;
304      eqv = SvPVX(tmpsv);
305    }
306    else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
307    for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
308    if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
309      getcwd(eqv,LNM$C_NAMLENGTH);
310      return eqv;
311    }
312    else {
313      if ((cp2 = strchr(lnm,';')) != NULL) {
314        strcpy(uplnm,lnm);
315        uplnm[cp2-lnm] = '\0';
316        idx = strtoul(cp2+1,NULL,0);
317        lnm = uplnm;
318      }
319      /* Impose security constraints only if tainting */
320      if (sys) {
321        /* Impose security constraints only if tainting */
322        secure = PL_curinterp ? PL_tainting : will_taint;
323        saverr = errno;  savvmserr = vaxc$errno;
324      }
325      else secure = 0;
326      success = vmstrnenv(lnm,eqv,idx,
327                          secure ? fildev : NULL,
328#ifdef SECURE_INTERNAL_GETENV
329                          secure ? PERL__TRNENV_SECURE : 0
330#else
331                          0
332#endif
333                                                             );
334      /* Discard NOLOGNAM on internal calls since we're often looking
335       * for an optional name, and this "error" often shows up as the
336       * (bogus) exit status for a die() call later on.  */
337      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
338      return success ? eqv : Nullch;
339    }
340
341}  /* end of my_getenv() */
342/*}}}*/
343
344
345/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
346char *
347my_getenv_len(const char *lnm, unsigned long *len, bool sys)
348{
349    dTHX;
350    char *buf, *cp1, *cp2;
351    unsigned long idx = 0;
352    static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
353    int secure, saverr, savvmserr;
354    SV *tmpsv;
355   
356    if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
357      /* Set up a temporary buffer for the return value; Perl will
358       * clean it up at the next statement transition */
359      tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
360      if (!tmpsv) return NULL;
361      buf = SvPVX(tmpsv);
362    }
363    else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
364    for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
365    if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
366      getcwd(buf,LNM$C_NAMLENGTH);
367      *len = strlen(buf);
368      return buf;
369    }
370    else {
371      if ((cp2 = strchr(lnm,';')) != NULL) {
372        strcpy(buf,lnm);
373        buf[cp2-lnm] = '\0';
374        idx = strtoul(cp2+1,NULL,0);
375        lnm = buf;
376      }
377      if (sys) {
378        /* Impose security constraints only if tainting */
379        secure = PL_curinterp ? PL_tainting : will_taint;
380        saverr = errno;  savvmserr = vaxc$errno;
381      }
382      else secure = 0;
383      *len = vmstrnenv(lnm,buf,idx,
384                       secure ? fildev : NULL,
385#ifdef SECURE_INTERNAL_GETENV
386                       secure ? PERL__TRNENV_SECURE : 0
387#else
388                                                      0
389#endif
390                                                       );
391      /* Discard NOLOGNAM on internal calls since we're often looking
392       * for an optional name, and this "error" often shows up as the
393       * (bogus) exit status for a die() call later on.  */
394      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
395      return *len ? buf : Nullch;
396    }
397
398}  /* end of my_getenv_len() */
399/*}}}*/
400
401static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
402
403static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
404
405/*{{{ void prime_env_iter() */
406void
407prime_env_iter(void)
408/* Fill the %ENV associative array with all logical names we can
409 * find, in preparation for iterating over it.
410 */
411{
412  dTHX;
413  static int primed = 0;
414  HV *seenhv = NULL, *envhv;
415  char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
416  unsigned short int chan;
417#ifndef CLI$M_TRUSTED
418#  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
419#endif
420  unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
421  unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
422  long int i;
423  bool have_sym = FALSE, have_lnm = FALSE;
424  struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
425  $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
426  $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
427  $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
428  $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
429#if defined(USE_THREADS) || defined(USE_ITHREADS)
430  static perl_mutex primenv_mutex;
431  MUTEX_INIT(&primenv_mutex);
432#endif
433
434  if (primed || !PL_envgv) return;
435  MUTEX_LOCK(&primenv_mutex);
436  if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
437  envhv = GvHVn(PL_envgv);
438  /* Perform a dummy fetch as an lval to insure that the hash table is
439   * set up.  Otherwise, the hv_store() will turn into a nullop. */
440  (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
441
442  for (i = 0; env_tables[i]; i++) {
443     if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
444         !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
445     if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
446  }
447  if (have_sym || have_lnm) {
448    long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
449    _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
450    _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
451    _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
452  }
453
454  for (i--; i >= 0; i--) {
455    if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
456      char *start;
457      int j;
458      for (j = 0; environ[j]; j++) {
459        if (!(start = strchr(environ[j],'='))) {
460          if (ckWARN(WARN_INTERNAL))
461            Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
462        }
463        else {
464          start++;
465          (void) hv_store(envhv,environ[j],start - environ[j] - 1,
466                          newSVpv(start,0),0);
467        }
468      }
469      continue;
470    }
471    else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
472             !str$case_blind_compare(&tmpdsc,&clisym)) {
473      strcpy(cmd,"Show Symbol/Global *");
474      cmddsc.dsc$w_length = 20;
475      if (env_tables[i]->dsc$w_length == 12 &&
476          (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
477          !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
478      flags = defflags | CLI$M_NOLOGNAM;
479    }
480    else {
481      strcpy(cmd,"Show Logical *");
482      if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
483        strcat(cmd," /Table=");
484        strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
485        cmddsc.dsc$w_length = strlen(cmd);
486      }
487      else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
488      flags = defflags | CLI$M_NOCLISYM;
489    }
490   
491    /* Create a new subprocess to execute each command, to exclude the
492     * remote possibility that someone could subvert a mbx or file used
493     * to write multiple commands to a single subprocess.
494     */
495    do {
496      retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
497                         0,&riseandshine,0,0,&clidsc,&clitabdsc);
498      flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
499      defflags &= ~CLI$M_TRUSTED;
500    } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
501    _ckvmssts(retsts);
502    if (!buf) New(1322,buf,mbxbufsiz + 1,char);
503    if (seenhv) SvREFCNT_dec(seenhv);
504    seenhv = newHV();
505    while (1) {
506      char *cp1, *cp2, *key;
507      unsigned long int sts, iosb[2], retlen, keylen;
508      register U32 hash;
509
510      sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
511      if (sts & 1) sts = iosb[0] & 0xffff;
512      if (sts == SS$_ENDOFFILE) {
513        int wakect = 0;
514        while (substs == 0) { sys$hiber(); wakect++;}
515        if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
516        _ckvmssts(substs);
517        break;
518      }
519      _ckvmssts(sts);
520      retlen = iosb[0] >> 16;     
521      if (!retlen) continue;  /* blank line */
522      buf[retlen] = '\0';
523      if (iosb[1] != subpid) {
524        if (iosb[1]) {
525          Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
526        }
527        continue;
528      }
529      if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
530        Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
531
532      for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
533      if (*cp1 == '(' || /* Logical name table name */
534          *cp1 == '='    /* Next eqv of searchlist  */) continue;
535      if (*cp1 == '"') cp1++;
536      for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
537      key = cp1;  keylen = cp2 - cp1;
538      if (keylen && hv_exists(seenhv,key,keylen)) continue;
539      while (*cp2 && *cp2 != '=') cp2++;
540      while (*cp2 && *cp2 == '=') cp2++;
541      while (*cp2 && *cp2 == ' ') cp2++;
542      if (*cp2 == '"') {  /* String translation; may embed "" */
543        for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
544        cp2++;  cp1--; /* Skip "" surrounding translation */
545      }
546      else {  /* Numeric translation */
547        for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
548        cp1--;  /* stop on last non-space char */
549      }
550      if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
551        Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
552        continue;
553      }
554      PERL_HASH(hash,key,keylen);
555      hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
556      hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
557    }
558    if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
559      /* get the PPFs for this process, not the subprocess */
560      char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
561      char eqv[LNM$C_NAMLENGTH+1];
562      int trnlen, i;
563      for (i = 0; ppfs[i]; i++) {
564        trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
565        hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
566      }
567    }
568  }
569  primed = 1;
570  if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
571  if (buf) Safefree(buf);
572  if (seenhv) SvREFCNT_dec(seenhv);
573  MUTEX_UNLOCK(&primenv_mutex);
574  return;
575
576}  /* end of prime_env_iter */
577/*}}}*/
578
579
580/*{{{ int  vmssetenv(char *lnm, char *eqv)*/
581/* Define or delete an element in the same "environment" as
582 * vmstrnenv().  If an element is to be deleted, it's removed from
583 * the first place it's found.  If it's to be set, it's set in the
584 * place designated by the first element of the table vector.
585 * Like setenv() returns 0 for success, non-zero on error.
586 */
587int
588vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
589{
590    char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
591    unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
592    unsigned long int retsts, usermode = PSL$C_USER;
593    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
594                            eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
595                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
596    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
597    $DESCRIPTOR(local,"_LOCAL");
598    dTHX;
599
600    for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
601      *cp2 = _toupper(*cp1);
602      if (cp1 - lnm > LNM$C_NAMLENGTH) {
603        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
604        return SS$_IVLOGNAM;
605      }
606    }
607    lnmdsc.dsc$w_length = cp1 - lnm;
608    if (!tabvec || !*tabvec) tabvec = env_tables;
609
610    if (!eqv) {  /* we're deleting n element */
611      for (curtab = 0; tabvec[curtab]; curtab++) {
612        if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
613        int i;
614          for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
615            if ((cp1 = strchr(environ[i],'=')) &&
616                !strncmp(environ[i],lnm,cp1 - environ[i])) {
617#ifdef HAS_SETENV
618              return setenv(lnm,"",1) ? vaxc$errno : 0;
619            }
620          }
621          ivenv = 1; retsts = SS$_NOLOGNAM;
622#else
623              if (ckWARN(WARN_INTERNAL))
624                Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
625              ivenv = 1; retsts = SS$_NOSUCHPGM;
626              break;
627            }
628          }
629#endif
630        }
631        else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
632                 !str$case_blind_compare(&tmpdsc,&clisym)) {
633          unsigned int symtype;
634          if (tabvec[curtab]->dsc$w_length == 12 &&
635              (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
636              !str$case_blind_compare(&tmpdsc,&local))
637            symtype = LIB$K_CLI_LOCAL_SYM;
638          else symtype = LIB$K_CLI_GLOBAL_SYM;
639          retsts = lib$delete_symbol(&lnmdsc,&symtype);
640          if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
641          if (retsts == LIB$_NOSUCHSYM) continue;
642          break;
643        }
644        else if (!ivlnm) {
645          retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
646          if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
647          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
648          retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
649          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
650        }
651      }
652    }
653    else {  /* we're defining a value */
654      if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
655#ifdef HAS_SETENV
656        return setenv(lnm,eqv,1) ? vaxc$errno : 0;
657#else
658        if (ckWARN(WARN_INTERNAL))
659          Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
660        retsts = SS$_NOSUCHPGM;
661#endif
662      }
663      else {
664        eqvdsc.dsc$a_pointer = eqv;
665        eqvdsc.dsc$w_length  = strlen(eqv);
666        if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
667            !str$case_blind_compare(&tmpdsc,&clisym)) {
668          unsigned int symtype;
669          if (tabvec[0]->dsc$w_length == 12 &&
670              (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
671               !str$case_blind_compare(&tmpdsc,&local))
672            symtype = LIB$K_CLI_LOCAL_SYM;
673          else symtype = LIB$K_CLI_GLOBAL_SYM;
674          retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
675        }
676        else {
677          if (!*eqv) eqvdsc.dsc$w_length = 1;
678          if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
679            eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
680            if (ckWARN(WARN_MISC)) {
681              Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
682            }
683          }
684          retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
685        }
686      }
687    }
688    if (!(retsts & 1)) {
689      switch (retsts) {
690        case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
691        case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
692          set_errno(EVMSERR); break;
693        case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
694        case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
695          set_errno(EINVAL); break;
696        case SS$_NOPRIV:
697          set_errno(EACCES);
698        default:
699          _ckvmssts(retsts);
700          set_errno(EVMSERR);
701       }
702       set_vaxc_errno(retsts);
703       return (int) retsts || 44; /* retsts should never be 0, but just in case */
704    }
705    else {
706      /* We reset error values on success because Perl does an hv_fetch()
707       * before each hv_store(), and if the thing we're setting didn't
708       * previously exist, we've got a leftover error message.  (Of course,
709       * this fails in the face of
710       *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
711       * in that the error reported in $! isn't spurious,
712       * but it's right more often than not.)
713       */
714      set_errno(0); set_vaxc_errno(retsts);
715      return 0;
716    }
717
718}  /* end of vmssetenv() */
719/*}}}*/
720
721/*{{{ void  my_setenv(char *lnm, char *eqv)*/
722/* This has to be a function since there's a prototype for it in proto.h */
723void
724Perl_my_setenv(pTHX_ char *lnm,char *eqv)
725{
726    if (lnm && *lnm) {
727      int len = strlen(lnm);
728      if  (len == 7) {
729        char uplnm[8];
730        int i;
731        for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
732        if (!strcmp(uplnm,"DEFAULT")) {
733          if (eqv && *eqv) chdir(eqv);
734          return;
735        }
736    }
737#ifndef RTL_USES_UTC
738    if (len == 6 || len == 2) {
739      char uplnm[7];
740      int i;
741      for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
742      uplnm[len] = '\0';
743      if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
744      if (!strcmp(uplnm,"TZ")) tz_updated = 1;
745    }
746#endif
747  }
748  (void) vmssetenv(lnm,eqv,NULL);
749}
750/*}}}*/
751
752/*{{{static void vmssetuserlnm(char *name, char *eqv);
753/*  vmssetuserlnm
754 *  sets a user-mode logical in the process logical name table
755 *  used for redirection of sys$error
756 */
757void
758Perl_vmssetuserlnm(char *name, char *eqv)
759{
760    $DESCRIPTOR(d_tab, "LNM$PROCESS");
761    struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
762    unsigned long int iss, attr = LNM$M_CONFINE;
763    unsigned char acmode = PSL$C_USER;
764    struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
765                                 {0, 0, 0, 0}};
766    d_name.dsc$a_pointer = name;
767    d_name.dsc$w_length = strlen(name);
768
769    lnmlst[0].buflen = strlen(eqv);
770    lnmlst[0].bufadr = eqv;
771
772    iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
773    if (!(iss&1)) lib$signal(iss);
774}
775/*}}}*/
776
777
778/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
779/* my_crypt - VMS password hashing
780 * my_crypt() provides an interface compatible with the Unix crypt()
781 * C library function, and uses sys$hash_password() to perform VMS
782 * password hashing.  The quadword hashed password value is returned
783 * as a NUL-terminated 8 character string.  my_crypt() does not change
784 * the case of its string arguments; in order to match the behavior
785 * of LOGINOUT et al., alphabetic characters in both arguments must
786 *  be upcased by the caller.
787 */
788char *
789my_crypt(const char *textpasswd, const char *usrname)
790{
791#   ifndef UAI$C_PREFERRED_ALGORITHM
792#     define UAI$C_PREFERRED_ALGORITHM 127
793#   endif
794    unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
795    unsigned short int salt = 0;
796    unsigned long int sts;
797    struct const_dsc {
798        unsigned short int dsc$w_length;
799        unsigned char      dsc$b_type;
800        unsigned char      dsc$b_class;
801        const char *       dsc$a_pointer;
802    }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
803       txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
804    struct itmlst_3 uailst[3] = {
805        { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
806        { sizeof salt, UAI$_SALT,    &salt, 0},
807        { 0,           0,            NULL,  NULL}};
808    static char hash[9];
809
810    usrdsc.dsc$w_length = strlen(usrname);
811    usrdsc.dsc$a_pointer = usrname;
812    if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
813      switch (sts) {
814        case SS$_NOGRPPRV: case SS$_NOSYSPRV:
815          set_errno(EACCES);
816          break;
817        case RMS$_RNF:
818          set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
819          break;
820        default:
821          set_errno(EVMSERR);
822      }
823      set_vaxc_errno(sts);
824      if (sts != RMS$_RNF) return NULL;
825    }
826
827    txtdsc.dsc$w_length = strlen(textpasswd);
828    txtdsc.dsc$a_pointer = textpasswd;
829    if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
830      set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
831    }
832
833    return (char *) hash;
834
835}  /* end of my_crypt() */
836/*}}}*/
837
838
839static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
840static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
841static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
842
843/*{{{int do_rmdir(char *name)*/
844int
845Perl_do_rmdir(pTHX_ char *name)
846{
847    char dirfile[NAM$C_MAXRSS+1];
848    int retval;
849    Stat_t st;
850
851    if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
852    if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
853    else retval = kill_file(dirfile);
854    return retval;
855
856}  /* end of do_rmdir */
857/*}}}*/
858
859/* kill_file
860 * Delete any file to which user has control access, regardless of whether
861 * delete access is explicitly allowed.
862 * Limitations: User must have write access to parent directory.
863 *              Does not block signals or ASTs; if interrupted in midstream
864 *              may leave file with an altered ACL.
865 * HANDLE WITH CARE!
866 */
867/*{{{int kill_file(char *name)*/
868int
869kill_file(char *name)
870{
871    char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
872    unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
873    unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
874    dTHX;
875    struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
876    struct myacedef {
877      unsigned char myace$b_length;
878      unsigned char myace$b_type;
879      unsigned short int myace$w_flags;
880      unsigned long int myace$l_access;
881      unsigned long int myace$l_ident;
882    } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
883                 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
884      oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
885     struct itmlst_3
886       findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
887                     {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
888       addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
889       dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
890       lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
891       ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
892     
893    /* Expand the input spec using RMS, since the CRTL remove() and
894     * system services won't do this by themselves, so we may miss
895     * a file "hiding" behind a logical name or search list. */
896    if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
897    if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
898    if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
899    /* If not, can changing protections help? */
900    if (vaxc$errno != RMS$_PRV) return -1;
901
902    /* No, so we get our own UIC to use as a rights identifier,
903     * and the insert an ACE at the head of the ACL which allows us
904     * to delete the file.
905     */
906    _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
907    fildsc.dsc$w_length = strlen(rspec);
908    fildsc.dsc$a_pointer = rspec;
909    cxt = 0;
910    newace.myace$l_ident = oldace.myace$l_ident;
911    if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
912      switch (aclsts) {
913        case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
914          set_errno(ENOENT); break;
915        case RMS$_DIR:
916          set_errno(ENOTDIR); break;
917        case RMS$_DEV:
918          set_errno(ENODEV); break;
919        case RMS$_SYN: case SS$_INVFILFOROP:
920          set_errno(EINVAL); break;
921        case RMS$_PRV:
922          set_errno(EACCES); break;
923        default:
924          _ckvmssts(aclsts);
925      }
926      set_vaxc_errno(aclsts);
927      return -1;
928    }
929    /* Grab any existing ACEs with this identifier in case we fail */
930    aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
931    if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
932                    || fndsts == SS$_NOMOREACE ) {
933      /* Add the new ACE . . . */
934      if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
935        goto yourroom;
936      if ((rmsts = remove(name))) {
937        /* We blew it - dir with files in it, no write priv for
938         * parent directory, etc.  Put things back the way they were. */
939        if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
940          goto yourroom;
941        if (fndsts & 1) {
942          addlst[0].bufadr = &oldace;
943          if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
944            goto yourroom;
945        }
946      }
947    }
948
949    yourroom:
950    fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
951    /* We just deleted it, so of course it's not there.  Some versions of
952     * VMS seem to return success on the unlock operation anyhow (after all
953     * the unlock is successful), but others don't.
954     */
955    if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
956    if (aclsts & 1) aclsts = fndsts;
957    if (!(aclsts & 1)) {
958      set_errno(EVMSERR);
959      set_vaxc_errno(aclsts);
960      return -1;
961    }
962
963    return rmsts;
964
965}  /* end of kill_file() */
966/*}}}*/
967
968
969/*{{{int my_mkdir(char *,Mode_t)*/
970int
971my_mkdir(char *dir, Mode_t mode)
972{
973  STRLEN dirlen = strlen(dir);
974  dTHX;
975
976  /* zero length string sometimes gives ACCVIO */
977  if (dirlen == 0) return -1;
978
979  /* CRTL mkdir() doesn't tolerate trailing /, since that implies
980   * null file name/type.  However, it's commonplace under Unix,
981   * so we'll allow it for a gain in portability.
982   */
983  if (dir[dirlen-1] == '/') {
984    char *newdir = savepvn(dir,dirlen-1);
985    int ret = mkdir(newdir,mode);
986    Safefree(newdir);
987    return ret;
988  }
989  else return mkdir(dir,mode);
990}  /* end of my_mkdir */
991/*}}}*/
992
993/*{{{int my_chdir(char *)*/
994int
995my_chdir(char *dir)
996{
997  STRLEN dirlen = strlen(dir);
998  dTHX;
999
1000  /* zero length string sometimes gives ACCVIO */
1001  if (dirlen == 0) return -1;
1002
1003  /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1004   * that implies
1005   * null file name/type.  However, it's commonplace under Unix,
1006   * so we'll allow it for a gain in portability.
1007   */
1008  if (dir[dirlen-1] == '/') {
1009    char *newdir = savepvn(dir,dirlen-1);
1010    int ret = chdir(newdir);
1011    Safefree(newdir);
1012    return ret;
1013  }
1014  else return chdir(dir);
1015}  /* end of my_chdir */
1016/*}}}*/
1017
1018
1019/*{{{FILE *my_tmpfile()*/
1020FILE *
1021my_tmpfile(void)
1022{
1023  FILE *fp;
1024  char *cp;
1025  dTHX;
1026
1027  if ((fp = tmpfile())) return fp;
1028
1029  New(1323,cp,L_tmpnam+24,char);
1030  strcpy(cp,"Sys$Scratch:");
1031  tmpnam(cp+strlen(cp));
1032  strcat(cp,".Perltmp");
1033  fp = fopen(cp,"w+","fop=dlt");
1034  Safefree(cp);
1035  return fp;
1036}
1037/*}}}*/
1038
1039/* default piping mailbox size */
1040#define PERL_BUFSIZ        512
1041
1042
1043static void
1044create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1045{
1046  unsigned long int mbxbufsiz;
1047  static unsigned long int syssize = 0;
1048  unsigned long int dviitm = DVI$_DEVNAM;
1049  dTHX;
1050  char csize[LNM$C_NAMLENGTH+1];
1051 
1052  if (!syssize) {
1053    unsigned long syiitm = SYI$_MAXBUF;
1054    /*
1055     * Get the SYSGEN parameter MAXBUF
1056     *
1057     * If the logical 'PERL_MBX_SIZE' is defined
1058     * use the value of the logical instead of PERL_BUFSIZ, but
1059     * keep the size between 128 and MAXBUF.
1060     *
1061     */
1062    _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1063  }
1064
1065  if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1066      mbxbufsiz = atoi(csize);
1067  } else {
1068      mbxbufsiz = PERL_BUFSIZ;
1069  }
1070  if (mbxbufsiz < 128) mbxbufsiz = 128;
1071  if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1072
1073  _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1074
1075  _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1076  namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1077
1078}  /* end of create_mbx() */
1079
1080
1081/*{{{  my_popen and my_pclose*/
1082
1083typedef struct _iosb           IOSB;
1084typedef struct _iosb*         pIOSB;
1085typedef struct _pipe           Pipe;
1086typedef struct _pipe*         pPipe;
1087typedef struct pipe_details    Info;
1088typedef struct pipe_details*  pInfo;
1089typedef struct _srqp            RQE;
1090typedef struct _srqp*          pRQE;
1091typedef struct _tochildbuf      CBuf;
1092typedef struct _tochildbuf*    pCBuf;
1093
1094struct _iosb {
1095    unsigned short status;
1096    unsigned short count;
1097    unsigned long  dvispec;
1098};
1099
1100#pragma member_alignment save
1101#pragma nomember_alignment quadword
1102struct _srqp {          /* VMS self-relative queue entry */
1103    unsigned long qptr[2];
1104};
1105#pragma member_alignment restore
1106static RQE  RQE_ZERO = {0,0};
1107
1108struct _tochildbuf {
1109    RQE             q;
1110    int             eof;
1111    unsigned short  size;
1112    char            *buf;
1113};
1114
1115struct _pipe {
1116    RQE            free;
1117    RQE            wait;
1118    int            fd_out;
1119    unsigned short chan_in;
1120    unsigned short chan_out;
1121    char          *buf;
1122    unsigned int   bufsize;
1123    IOSB           iosb;
1124    IOSB           iosb2;
1125    int           *pipe_done;
1126    int            retry;
1127    int            type;
1128    int            shut_on_empty;
1129    int            need_wake;
1130    pPipe         *home;
1131    pInfo          info;
1132    pCBuf          curr;
1133    pCBuf          curr2;
1134};
1135
1136
1137struct pipe_details
1138{
1139    pInfo           next;
1140    PerlIO *fp;  /* stdio file pointer to pipe mailbox */
1141    int pid;   /* PID of subprocess */
1142    int mode;  /* == 'r' if pipe open for reading */
1143    int done;  /* subprocess has completed */
1144    int             closing;        /* my_pclose is closing this pipe */
1145    unsigned long   completion;     /* termination status of subprocess */
1146    pPipe           in;             /* pipe in to sub */
1147    pPipe           out;            /* pipe out of sub */
1148    pPipe           err;            /* pipe of sub's sys$error */
1149    int             in_done;        /* true when in pipe finished */
1150    int             out_done;
1151    int             err_done;
1152};
1153
1154struct exit_control_block
1155{
1156    struct exit_control_block *flink;
1157    unsigned long int   (*exit_routine)();
1158    unsigned long int arg_count;
1159    unsigned long int *status_address;
1160    unsigned long int exit_status;
1161};
1162
1163#define RETRY_DELAY     "0 ::0.20"
1164#define MAX_RETRY              50
1165
1166static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1167static unsigned long mypid;
1168static unsigned long delaytime[2];
1169
1170static pInfo open_pipes = NULL;
1171static $DESCRIPTOR(nl_desc, "NL:");
1172
1173
1174static unsigned long int
1175pipe_exit_routine()
1176{
1177    pInfo info;
1178    unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1179    int sts, did_stuff, need_eof;
1180    dTHX;
1181
1182    /*
1183     first we try sending an EOF...ignore if doesn't work, make sure we
1184     don't hang
1185    */
1186    did_stuff = 0;
1187    info = open_pipes;
1188
1189    while (info) {
1190      int need_eof;
1191      _ckvmssts(sys$setast(0));
1192      if (info->in && !info->in->shut_on_empty) {
1193        _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1194                          0, 0, 0, 0, 0, 0));
1195        did_stuff = 1;
1196      }
1197      _ckvmssts(sys$setast(1));
1198      info = info->next;
1199    }
1200    if (did_stuff) sleep(1);   /* wait for EOF to have an effect */
1201
1202    did_stuff = 0;
1203    info = open_pipes;
1204    while (info) {
1205      _ckvmssts(sys$setast(0));
1206      if (!info->done) { /* Tap them gently on the shoulder . . .*/
1207        sts = sys$forcex(&info->pid,0,&abort);
1208        if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1209        did_stuff = 1;
1210      }
1211      _ckvmssts(sys$setast(1));
1212      info = info->next;
1213    }
1214    if (did_stuff) sleep(1);    /* wait for them to respond */
1215
1216    info = open_pipes;
1217    while (info) {
1218      _ckvmssts(sys$setast(0));
1219      if (!info->done) {  /* We tried to be nice . . . */
1220        sts = sys$delprc(&info->pid,0);
1221        if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1222      }
1223      _ckvmssts(sys$setast(1));
1224      info = info->next;
1225    }
1226
1227    while(open_pipes) {
1228      if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1229      else if (!(sts & 1)) retsts = sts;
1230    }
1231    return retsts;
1232}
1233
1234static struct exit_control_block pipe_exitblock =
1235       {(struct exit_control_block *) 0,
1236        pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1237
1238static void pipe_mbxtofd_ast(pPipe p);
1239static void pipe_tochild1_ast(pPipe p);
1240static void pipe_tochild2_ast(pPipe p);
1241
1242static void
1243popen_completion_ast(pInfo info)
1244{
1245  dTHX;
1246  pInfo i = open_pipes;
1247  int iss;
1248
1249  while (i) {
1250    if (i == info) break;
1251    i = i->next;
1252  }
1253  if (!i) return;       /* unlinked, probably freed too */
1254
1255  info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1256  info->done = TRUE;
1257
1258/*
1259    Writing to subprocess ...
1260            if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1261
1262            chan_out may be waiting for "done" flag, or hung waiting
1263            for i/o completion to child...cancel the i/o.  This will
1264            put it into "snarf mode" (done but no EOF yet) that discards
1265            input.
1266
1267    Output from subprocess (stdout, stderr) needs to be flushed and
1268    shut down.   We try sending an EOF, but if the mbx is full the pipe
1269    routine should still catch the "shut_on_empty" flag, telling it to
1270    use immediate-style reads so that "mbx empty" -> EOF.
1271
1272
1273*/
1274  if (info->in && !info->in_done) {               /* only for mode=w */
1275        if (info->in->shut_on_empty && info->in->need_wake) {
1276            info->in->need_wake = FALSE;
1277            _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1278        } else {
1279            _ckvmssts(sys$cancel(info->in->chan_out));
1280        }
1281  }
1282
1283  if (info->out && !info->out_done) {             /* were we also piping output? */
1284      info->out->shut_on_empty = TRUE;
1285      iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1286      if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1287      _ckvmssts(iss);
1288  }
1289
1290  if (info->err && !info->err_done) {        /* we were piping stderr */
1291        info->err->shut_on_empty = TRUE;
1292        iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1293        if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1294        _ckvmssts(iss);
1295  }
1296  _ckvmssts(sys$setef(pipe_ef));
1297
1298}
1299
1300static unsigned long int setup_cmddsc(char *cmd, int check_img);
1301static void vms_execfree(pTHX);
1302
1303/*
1304    we actually differ from vmstrnenv since we use this to
1305    get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1306    are pointing to the same thing
1307*/
1308
1309static unsigned short
1310popen_translate(char *logical, char *result)
1311{
1312    int iss;
1313    $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1314    $DESCRIPTOR(d_log,"");
1315    struct _il3 {
1316        unsigned short length;
1317        unsigned short code;
1318        char *         buffer_addr;
1319        unsigned short *retlenaddr;
1320    } itmlst[2];
1321    unsigned short l, ifi;
1322
1323    d_log.dsc$a_pointer = logical;
1324    d_log.dsc$w_length  = strlen(logical);
1325
1326    itmlst[0].code = LNM$_STRING;
1327    itmlst[0].length = 255;
1328    itmlst[0].buffer_addr = result;
1329    itmlst[0].retlenaddr = &l;
1330
1331    itmlst[1].code = 0;
1332    itmlst[1].length = 0;
1333    itmlst[1].buffer_addr = 0;
1334    itmlst[1].retlenaddr = 0;
1335
1336    iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1337    if (iss == SS$_NOLOGNAM) {
1338        iss = SS$_NORMAL;
1339        l = 0;
1340    }
1341    if (!(iss&1)) lib$signal(iss);
1342    result[l] = '\0';
1343/*
1344    logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1345    strip it off and return the ifi, if any
1346*/
1347    ifi  = 0;
1348    if (result[0] == 0x1b && result[1] == 0x00) {
1349        memcpy(&ifi,result+2,2);
1350        strcpy(result,result+4);
1351    }
1352    return ifi;     /* this is the RMS internal file id */
1353}
1354
1355#define MAX_DCL_SYMBOL        255
1356static void pipe_infromchild_ast(pPipe p);
1357
1358/*
1359    I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1360    inside an AST routine without worrying about reentrancy and which Perl
1361    memory allocator is being used.
1362
1363    We read data and queue up the buffers, then spit them out one at a
1364    time to the output mailbox when the output mailbox is ready for one.
1365
1366*/
1367#define INITIAL_TOCHILDQUEUE  2
1368
1369static pPipe
1370pipe_tochild_setup(char *rmbx, char *wmbx)
1371{
1372    dTHX;
1373    pPipe p;
1374    pCBuf b;
1375    char mbx1[64], mbx2[64];
1376    struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1377                                      DSC$K_CLASS_S, mbx1},
1378                            d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1379                                      DSC$K_CLASS_S, mbx2};
1380    unsigned int dviitm = DVI$_DEVBUFSIZ;
1381    int j, n;
1382
1383    New(1368, p, 1, Pipe);
1384
1385    create_mbx(&p->chan_in , &d_mbx1);
1386    create_mbx(&p->chan_out, &d_mbx2);
1387    _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1388
1389    p->buf           = 0;
1390    p->shut_on_empty = FALSE;
1391    p->need_wake     = FALSE;
1392    p->type          = 0;
1393    p->retry         = 0;
1394    p->iosb.status   = SS$_NORMAL;
1395    p->iosb2.status  = SS$_NORMAL;
1396    p->free          = RQE_ZERO;
1397    p->wait          = RQE_ZERO;
1398    p->curr          = 0;
1399    p->curr2         = 0;
1400    p->info          = 0;
1401
1402    n = sizeof(CBuf) + p->bufsize;
1403
1404    for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1405        _ckvmssts(lib$get_vm(&n, &b));
1406        b->buf = (char *) b + sizeof(CBuf);
1407        _ckvmssts(lib$insqhi(b, &p->free));
1408    }
1409
1410    pipe_tochild2_ast(p);
1411    pipe_tochild1_ast(p);
1412    strcpy(wmbx, mbx1);
1413    strcpy(rmbx, mbx2);
1414    return p;
1415}
1416
1417/*  reads the MBX Perl is writing, and queues */
1418
1419static void
1420pipe_tochild1_ast(pPipe p)
1421{
1422    dTHX;
1423    pCBuf b = p->curr;
1424    int iss = p->iosb.status;
1425    int eof = (iss == SS$_ENDOFFILE);
1426
1427    if (p->retry) {
1428        if (eof) {
1429            p->shut_on_empty = TRUE;
1430            b->eof     = TRUE;
1431            _ckvmssts(sys$dassgn(p->chan_in));
1432        } else  {
1433            _ckvmssts(iss);
1434        }
1435
1436        b->eof  = eof;
1437        b->size = p->iosb.count;
1438        _ckvmssts(lib$insqhi(b, &p->wait));
1439        if (p->need_wake) {
1440            p->need_wake = FALSE;
1441            _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1442        }
1443    } else {
1444        p->retry = 1;   /* initial call */
1445    }
1446
1447    if (eof) {                  /* flush the free queue, return when done */
1448        int n = sizeof(CBuf) + p->bufsize;
1449        while (1) {
1450            iss = lib$remqti(&p->free, &b);
1451            if (iss == LIB$_QUEWASEMP) return;
1452            _ckvmssts(iss);
1453            _ckvmssts(lib$free_vm(&n, &b));
1454        }
1455    }
1456
1457    iss = lib$remqti(&p->free, &b);
1458    if (iss == LIB$_QUEWASEMP) {
1459        int n = sizeof(CBuf) + p->bufsize;
1460        _ckvmssts(lib$get_vm(&n, &b));
1461        b->buf = (char *) b + sizeof(CBuf);
1462    } else {
1463       _ckvmssts(iss);
1464    }
1465
1466    p->curr = b;
1467    iss = sys$qio(0,p->chan_in,
1468             IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1469             &p->iosb,
1470             pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1471    if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1472    _ckvmssts(iss);
1473}
1474
1475
1476/* writes queued buffers to output, waits for each to complete before
1477   doing the next */
1478
1479static void
1480pipe_tochild2_ast(pPipe p)
1481{
1482    dTHX;
1483    pCBuf b = p->curr2;
1484    int iss = p->iosb2.status;
1485    int n = sizeof(CBuf) + p->bufsize;
1486    int done = (p->info && p->info->done) ||
1487              iss == SS$_CANCEL || iss == SS$_ABORT;
1488
1489    do {
1490        if (p->type) {         /* type=1 has old buffer, dispose */
1491            if (p->shut_on_empty) {
1492                _ckvmssts(lib$free_vm(&n, &b));
1493            } else {
1494                _ckvmssts(lib$insqhi(b, &p->free));
1495            }
1496            p->type = 0;
1497        }
1498
1499        iss = lib$remqti(&p->wait, &b);
1500        if (iss == LIB$_QUEWASEMP) {
1501            if (p->shut_on_empty) {
1502                if (done) {
1503                    _ckvmssts(sys$dassgn(p->chan_out));
1504                    *p->pipe_done = TRUE;
1505                    _ckvmssts(sys$setef(pipe_ef));
1506                } else {
1507                    _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1508                        &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1509                }
1510                return;
1511            }
1512            p->need_wake = TRUE;
1513            return;
1514        }
1515        _ckvmssts(iss);
1516        p->type = 1;
1517    } while (done);
1518
1519
1520    p->curr2 = b;
1521    if (b->eof) {
1522        _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1523            &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1524    } else {
1525        _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1526            &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1527    }
1528
1529    return;
1530
1531}
1532
1533
1534static pPipe
1535pipe_infromchild_setup(char *rmbx, char *wmbx)
1536{
1537    dTHX;
1538    pPipe p;
1539    char mbx1[64], mbx2[64];
1540    struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1541                                      DSC$K_CLASS_S, mbx1},
1542                            d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1543                                      DSC$K_CLASS_S, mbx2};
1544    unsigned int dviitm = DVI$_DEVBUFSIZ;
1545
1546    New(1367, p, 1, Pipe);
1547    create_mbx(&p->chan_in , &d_mbx1);
1548    create_mbx(&p->chan_out, &d_mbx2);
1549
1550    _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1551    New(1367, p->buf, p->bufsize, char);
1552    p->shut_on_empty = FALSE;
1553    p->info   = 0;
1554    p->type   = 0;
1555    p->iosb.status = SS$_NORMAL;
1556    pipe_infromchild_ast(p);
1557
1558    strcpy(wmbx, mbx1);
1559    strcpy(rmbx, mbx2);
1560    return p;
1561}
1562
1563static void
1564pipe_infromchild_ast(pPipe p)
1565{
1566    dTHX;
1567    int iss = p->iosb.status;
1568    int eof = (iss == SS$_ENDOFFILE);
1569    int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1570    int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1571
1572    if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1573        _ckvmssts(sys$dassgn(p->chan_out));
1574        p->chan_out = 0;
1575    }
1576
1577    /* read completed:
1578            input shutdown if EOF from self (done or shut_on_empty)
1579            output shutdown if closing flag set (my_pclose)
1580            send data/eof from child or eof from self
1581            otherwise, re-read (snarf of data from child)
1582    */
1583
1584    if (p->type == 1) {
1585        p->type = 0;
1586        if (myeof && p->chan_in) {                  /* input shutdown */
1587            _ckvmssts(sys$dassgn(p->chan_in));
1588            p->chan_in = 0;
1589        }
1590
1591        if (p->chan_out) {
1592            if (myeof || kideof) {      /* pass EOF to parent */
1593                _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1594                              pipe_infromchild_ast, p,
1595                              0, 0, 0, 0, 0, 0));
1596                return;
1597            } else if (eof) {       /* eat EOF --- fall through to read*/
1598
1599            } else {                /* transmit data */
1600                _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1601                              pipe_infromchild_ast,p,
1602                              p->buf, p->iosb.count, 0, 0, 0, 0));
1603                return;
1604            }
1605        }
1606    }
1607
1608    /*  everything shut? flag as done */
1609
1610    if (!p->chan_in && !p->chan_out) {
1611        *p->pipe_done = TRUE;
1612        _ckvmssts(sys$setef(pipe_ef));
1613        return;
1614    }
1615
1616    /* write completed (or read, if snarfing from child)
1617            if still have input active,
1618               queue read...immediate mode if shut_on_empty so we get EOF if empty
1619            otherwise,
1620               check if Perl reading, generate EOFs as needed
1621    */
1622
1623    if (p->type == 0) {
1624        p->type = 1;
1625        if (p->chan_in) {
1626            iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1627                          pipe_infromchild_ast,p,
1628                          p->buf, p->bufsize, 0, 0, 0, 0);
1629            if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1630            _ckvmssts(iss);
1631        } else {           /* send EOFs for extra reads */
1632            p->iosb.status = SS$_ENDOFFILE;
1633            p->iosb.dvispec = 0;
1634            _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1635                      0, 0, 0,
1636                      pipe_infromchild_ast, p, 0, 0, 0, 0));
1637        }
1638    }
1639}
1640
1641static pPipe
1642pipe_mbxtofd_setup(int fd, char *out)
1643{
1644    dTHX;
1645    pPipe p;
1646    char mbx[64];
1647    unsigned long dviitm = DVI$_DEVBUFSIZ;
1648    struct stat s;
1649    struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1650                                      DSC$K_CLASS_S, mbx};
1651
1652    /* things like terminals and mbx's don't need this filter */
1653    if (fd && fstat(fd,&s) == 0) {
1654        unsigned long dviitm = DVI$_DEVCHAR, devchar;
1655        struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1656                                         DSC$K_CLASS_S, s.st_dev};
1657
1658        _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1659        if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
1660            strcpy(out, s.st_dev);
1661            return 0;
1662        }
1663    }
1664
1665    New(1366, p, 1, Pipe);
1666    p->fd_out = dup(fd);
1667    create_mbx(&p->chan_in, &d_mbx);
1668    _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1669    New(1366, p->buf, p->bufsize+1, char);
1670    p->shut_on_empty = FALSE;
1671    p->retry = 0;
1672    p->info  = 0;
1673    strcpy(out, mbx);
1674
1675    _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1676                  pipe_mbxtofd_ast, p,
1677                  p->buf, p->bufsize, 0, 0, 0, 0));
1678
1679    return p;
1680}
1681
1682static void
1683pipe_mbxtofd_ast(pPipe p)
1684{
1685    dTHX;
1686    int iss = p->iosb.status;
1687    int done = p->info->done;
1688    int iss2;
1689    int eof = (iss == SS$_ENDOFFILE);
1690    int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1691    int err = !(iss&1) && !eof;
1692
1693
1694    if (done && myeof) {               /* end piping */
1695        close(p->fd_out);
1696        sys$dassgn(p->chan_in);
1697        *p->pipe_done = TRUE;
1698        _ckvmssts(sys$setef(pipe_ef));
1699        return;
1700    }
1701
1702    if (!err && !eof) {             /* good data to send to file */
1703        p->buf[p->iosb.count] = '\n';
1704        iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1705        if (iss2 < 0) {
1706            p->retry++;
1707            if (p->retry < MAX_RETRY) {
1708                _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1709                return;
1710            }
1711        }
1712        p->retry = 0;
1713    } else if (err) {
1714        _ckvmssts(iss);
1715    }
1716
1717
1718    iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1719          pipe_mbxtofd_ast, p,
1720          p->buf, p->bufsize, 0, 0, 0, 0);
1721    if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1722    _ckvmssts(iss);
1723}
1724
1725
1726typedef struct _pipeloc     PLOC;
1727typedef struct _pipeloc*   pPLOC;
1728
1729struct _pipeloc {
1730    pPLOC   next;
1731    char    dir[NAM$C_MAXRSS+1];
1732};
1733static pPLOC  head_PLOC = 0;
1734
1735void
1736free_pipelocs(void *head)
1737{
1738    pPLOC p, pnext;
1739
1740    p = (pPLOC) head;
1741    while (p) {
1742        pnext = p->next;
1743        Safefree(p);
1744        p = pnext;
1745    }
1746}
1747
1748static void
1749store_pipelocs()
1750{
1751    int    i;
1752    pPLOC  p;
1753    AV    *av = GvAVn(PL_incgv);
1754    SV    *dirsv;
1755    GV    *gv;
1756    char  *dir, *x;
1757    char  *unixdir;
1758    char  temp[NAM$C_MAXRSS+1];
1759    STRLEN n_a;
1760
1761/*  the . directory from @INC comes last */
1762
1763    New(1370,p,1,PLOC);
1764    p->next = head_PLOC;
1765    head_PLOC = p;
1766    strcpy(p->dir,"./");
1767
1768/*  get the directory from $^X */
1769
1770    if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
1771        strcpy(temp, PL_origargv[0]);
1772        x = strrchr(temp,']');
1773        if (x) x[1] = '\0';
1774
1775        if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1776            New(1370,p,1,PLOC);
1777            p->next = head_PLOC;
1778            head_PLOC = p;
1779            strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1780            p->dir[NAM$C_MAXRSS] = '\0';
1781        }
1782    }
1783
1784/*  reverse order of @INC entries, skip "." since entered above */
1785
1786    for (i = 0; i <= AvFILL(av); i++) {
1787        dirsv = *av_fetch(av,i,TRUE);
1788
1789        if (SvROK(dirsv)) continue;
1790        dir = SvPVx(dirsv,n_a);
1791        if (strcmp(dir,".") == 0) continue;
1792        if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1793            continue;
1794
1795        New(1370,p,1,PLOC);
1796        p->next = head_PLOC;
1797        head_PLOC = p;
1798        strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1799        p->dir[NAM$C_MAXRSS] = '\0';
1800    }
1801
1802/* most likely spot (ARCHLIB) put first in the list */
1803
1804#ifdef ARCHLIB_EXP
1805    if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1806        New(1370,p,1,PLOC);
1807        p->next = head_PLOC;
1808        head_PLOC = p;
1809        strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1810        p->dir[NAM$C_MAXRSS] = '\0';
1811    }
1812#endif
1813    Perl_call_atexit(&free_pipelocs, head_PLOC);
1814}
1815
1816
1817static char *
1818find_vmspipe(void)
1819{
1820    static int   vmspipe_file_status = 0;
1821    static char  vmspipe_file[NAM$C_MAXRSS+1];
1822
1823    /* already found? Check and use ... need read+execute permission */
1824
1825    if (vmspipe_file_status == 1) {
1826        if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1827         && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1828            return vmspipe_file;
1829        }
1830        vmspipe_file_status = 0;
1831    }
1832
1833    /* scan through stored @INC, $^X */
1834
1835    if (vmspipe_file_status == 0) {
1836        char file[NAM$C_MAXRSS+1];
1837        pPLOC  p = head_PLOC;
1838
1839        while (p) {
1840            strcpy(file, p->dir);
1841            strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1842            file[NAM$C_MAXRSS] = '\0';
1843            p = p->next;
1844
1845            if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1846
1847            if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1848             && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1849                vmspipe_file_status = 1;
1850                return vmspipe_file;
1851            }
1852        }
1853        vmspipe_file_status = -1;   /* failed, use tempfiles */
1854    }
1855
1856    return 0;
1857}
1858
1859static FILE *
1860vmspipe_tempfile(void)
1861{
1862    char file[NAM$C_MAXRSS+1];
1863    FILE *fp;
1864    static int index = 0;
1865    stat_t s0, s1;
1866
1867    /* create a tempfile */
1868
1869    /* we can't go from   W, shr=get to  R, shr=get without
1870       an intermediate vulnerable state, so don't bother trying...
1871
1872       and lib$spawn doesn't shr=put, so have to close the write
1873
1874       So... match up the creation date/time and the FID to
1875       make sure we're dealing with the same file
1876
1877    */
1878
1879    index++;
1880    sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1881    fp = fopen(file,"w");
1882    if (!fp) {
1883        sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1884        fp = fopen(file,"w");
1885        if (!fp) {
1886            sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1887            fp = fopen(file,"w");
1888        }
1889    }
1890    if (!fp) return 0;  /* we're hosed */
1891
1892    fprintf(fp,"$! 'f$verify(0)\n");
1893    fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
1894    fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
1895    fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1896    fprintf(fp,"$ perl_on     = \"set noon\"\n");
1897    fprintf(fp,"$ perl_exit   = \"exit\"\n");
1898    fprintf(fp,"$ perl_del    = \"delete\"\n");
1899    fprintf(fp,"$ pif         = \"if\"\n");
1900    fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
1901    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
1902    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
1903    fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
1904    fprintf(fp,"$ cmd = perl_popen_cmd\n");
1905    fprintf(fp,"$!  --- get rid of global symbols\n");
1906    fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1907    fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1908    fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1909    fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1910    fprintf(fp,"$ perl_on\n");
1911    fprintf(fp,"$ 'cmd\n");
1912    fprintf(fp,"$ perl_status = $STATUS\n");
1913    fprintf(fp,"$ perl_del  'perl_cfile'\n");
1914    fprintf(fp,"$ perl_exit 'perl_status'\n");
1915    fsync(fileno(fp));
1916
1917    fgetname(fp, file, 1);
1918    fstat(fileno(fp), &s0);
1919    fclose(fp);
1920
1921    fp = fopen(file,"r","shr=get");
1922    if (!fp) return 0;
1923    fstat(fileno(fp), &s1);
1924
1925    if (s0.st_ino[0] != s1.st_ino[0] ||
1926        s0.st_ino[1] != s1.st_ino[1] ||
1927        s0.st_ino[2] != s1.st_ino[2] ||
1928        s0.st_ctime  != s1.st_ctime  )  {
1929        fclose(fp);
1930        return 0;
1931    }
1932
1933    return fp;
1934}
1935
1936
1937
1938static PerlIO *
1939safe_popen(char *cmd, char *mode)
1940{
1941    dTHX;
1942    static int handler_set_up = FALSE;
1943    unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
1944    unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1945    char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1946    char in[512], out[512], err[512], mbx[512];
1947    FILE *tpipe = 0;
1948    char tfilebuf[NAM$C_MAXRSS+1];
1949    pInfo info;
1950    struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1951                                      DSC$K_CLASS_S, symbol};
1952    struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1953                                      DSC$K_CLASS_S, 0};
1954
1955    $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1956    $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1957    $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1958    $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1959                           
1960    /* once-per-program initialization...
1961       note that the SETAST calls and the dual test of pipe_ef
1962       makes sure that only the FIRST thread through here does
1963       the initialization...all other threads wait until it's
1964       done.
1965
1966       Yeah, uglier than a pthread call, it's got all the stuff inline
1967       rather than in a separate routine.
1968    */
1969
1970    if (!pipe_ef) {
1971        _ckvmssts(sys$setast(0));
1972        if (!pipe_ef) {
1973            unsigned long int pidcode = JPI$_PID;
1974            $DESCRIPTOR(d_delay, RETRY_DELAY);
1975            _ckvmssts(lib$get_ef(&pipe_ef));
1976            _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1977            _ckvmssts(sys$bintim(&d_delay, delaytime));
1978        }
1979        if (!handler_set_up) {
1980          _ckvmssts(sys$dclexh(&pipe_exitblock));
1981          handler_set_up = TRUE;
1982        }
1983        _ckvmssts(sys$setast(1));
1984    }
1985
1986    /* see if we can find a VMSPIPE.COM */
1987
1988    tfilebuf[0] = '@';
1989    vmspipe = find_vmspipe();
1990    if (vmspipe) {
1991        strcpy(tfilebuf+1,vmspipe);
1992    } else {        /* uh, oh...we're in tempfile hell */
1993        tpipe = vmspipe_tempfile();
1994        if (!tpipe) {       /* a fish popular in Boston */
1995            if (ckWARN(WARN_PIPE)) {
1996                Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1997            }
1998        return Nullfp;
1999        }
2000        fgetname(tpipe,tfilebuf+1,1);
2001    }
2002    vmspipedsc.dsc$a_pointer = tfilebuf;
2003    vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2004
2005    if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
2006    New(1301,info,1,Info);
2007       
2008    info->mode = *mode;
2009    info->done = FALSE;
2010    info->completion = 0;
2011    info->closing    = FALSE;
2012    info->in         = 0;
2013    info->out        = 0;
2014    info->err        = 0;
2015    info->in_done    = TRUE;
2016    info->out_done   = TRUE;
2017    info->err_done   = TRUE;
2018    in[0] = out[0] = err[0] = '\0';
2019
2020    if (*mode == 'r') {             /* piping from subroutine */
2021
2022        info->out = pipe_infromchild_setup(mbx,out);
2023        if (info->out) {
2024            info->out->pipe_done = &info->out_done;
2025            info->out_done = FALSE;
2026            info->out->info = info;
2027        }
2028        info->fp  = PerlIO_open(mbx, mode);
2029        if (!info->fp && info->out) {
2030            sys$cancel(info->out->chan_out);
2031       
2032            while (!info->out_done) {
2033                int done;
2034                _ckvmssts(sys$setast(0));
2035                done = info->out_done;
2036                if (!done) _ckvmssts(sys$clref(pipe_ef));
2037                _ckvmssts(sys$setast(1));
2038                if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2039            }
2040
2041            if (info->out->buf) Safefree(info->out->buf);
2042            Safefree(info->out);
2043            Safefree(info);
2044            return Nullfp;
2045        }
2046
2047        info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2048        if (info->err) {
2049            info->err->pipe_done = &info->err_done;
2050            info->err_done = FALSE;
2051            info->err->info = info;
2052        }
2053
2054    } else {                        /* piping to subroutine , mode=w*/
2055
2056        info->in = pipe_tochild_setup(in,mbx);
2057        info->fp  = PerlIO_open(mbx, mode);
2058        if (info->in) {
2059            info->in->pipe_done = &info->in_done;
2060            info->in_done = FALSE;
2061            info->in->info = info;
2062        }
2063
2064        /* error cleanup */
2065        if (!info->fp && info->in) {
2066            info->done = TRUE;
2067            _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2068                              0, 0, 0, 0, 0, 0, 0, 0));
2069
2070            while (!info->in_done) {
2071                int done;
2072                _ckvmssts(sys$setast(0));
2073                done = info->in_done;
2074                if (!done) _ckvmssts(sys$clref(pipe_ef));
2075                _ckvmssts(sys$setast(1));
2076                if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2077            }
2078
2079            if (info->in->buf) Safefree(info->in->buf);
2080            Safefree(info->in);
2081            Safefree(info);
2082            return Nullfp;
2083        }
2084       
2085
2086        info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2087        if (info->out) {
2088            info->out->pipe_done = &info->out_done;
2089            info->out_done = FALSE;
2090            info->out->info = info;
2091        }
2092
2093        info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2094        if (info->err) {
2095            info->err->pipe_done = &info->err_done;
2096            info->err_done = FALSE;
2097            info->err->info = info;
2098        }
2099    }
2100
2101    symbol[MAX_DCL_SYMBOL] = '\0';
2102
2103    strncpy(symbol, in, MAX_DCL_SYMBOL);
2104    d_symbol.dsc$w_length = strlen(symbol);
2105    _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2106
2107    strncpy(symbol, err, MAX_DCL_SYMBOL);
2108    d_symbol.dsc$w_length = strlen(symbol);
2109    _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2110
2111    strncpy(symbol, out, MAX_DCL_SYMBOL);
2112    d_symbol.dsc$w_length = strlen(symbol);
2113    _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2114
2115    p = VMScmd.dsc$a_pointer;
2116    while (*p && *p != '\n') p++;
2117    *p = '\0';                                  /* truncate on \n */
2118    p = VMScmd.dsc$a_pointer;
2119    while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2120    if (*p == '$') p++;                         /* remove leading $ */
2121    while (*p == ' ' || *p == '\t') p++;
2122    strncpy(symbol, p, MAX_DCL_SYMBOL);
2123    d_symbol.dsc$w_length = strlen(symbol);
2124    _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2125
2126    _ckvmssts(sys$setast(0));
2127    info->next=open_pipes;  /* prepend to list */
2128    open_pipes=info;
2129    _ckvmssts(sys$setast(1));
2130    _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2131                      0, &info->pid, &info->completion,
2132                      0, popen_completion_ast,info,0,0,0));
2133
2134    /* if we were using a tempfile, close it now */
2135
2136    if (tpipe) fclose(tpipe);
2137
2138    /* once the subprocess is spawned, its copied the symbols and
2139       we can get rid of ours */
2140
2141    _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2142    _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2143    _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2144    _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2145    vms_execfree(aTHX);
2146       
2147    PL_forkprocess = info->pid;
2148    return info->fp;
2149}  /* end of safe_popen */
2150
2151
2152/*{{{  FILE *my_popen(char *cmd, char *mode)*/
2153FILE *
2154Perl_my_popen(pTHX_ char *cmd, char *mode)
2155{
2156    TAINT_ENV();
2157    TAINT_PROPER("popen");
2158    PERL_FLUSHALL_FOR_CHILD;
2159    return safe_popen(cmd,mode);
2160}
2161
2162/*}}}*/
2163
2164/*{{{  I32 my_pclose(FILE *fp)*/
2165I32 Perl_my_pclose(pTHX_ FILE *fp)
2166{
2167    dTHX;
2168    pInfo info, last = NULL;
2169    unsigned long int retsts;
2170    int done, iss;
2171   
2172    for (info = open_pipes; info != NULL; last = info, info = info->next)
2173        if (info->fp == fp) break;
2174
2175    if (info == NULL) {  /* no such pipe open */
2176      set_errno(ECHILD); /* quoth POSIX */
2177      set_vaxc_errno(SS$_NONEXPR);
2178      return -1;
2179    }
2180
2181    /* If we were writing to a subprocess, insure that someone reading from
2182     * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2183     * produce an EOF record in the mailbox.
2184     *
2185     *  well, at least sometimes it *does*, so we have to watch out for
2186     *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2187     */
2188
2189     fsync(fileno(info->fp));   /* first, flush data */
2190
2191    _ckvmssts(sys$setast(0));
2192     info->closing = TRUE;
2193     done = info->done && info->in_done && info->out_done && info->err_done;
2194     /* hanging on write to Perl's input? cancel it */
2195     if (info->mode == 'r' && info->out && !info->out_done) {
2196        if (info->out->chan_out) {
2197            _ckvmssts(sys$cancel(info->out->chan_out));
2198            if (!info->out->chan_in) {   /* EOF generation, need AST */
2199                _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2200            }
2201        }
2202     }
2203     if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2204         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2205                           0, 0, 0, 0, 0, 0));
2206    _ckvmssts(sys$setast(1));
2207    PerlIO_close(info->fp);
2208
2209     /*
2210        we have to wait until subprocess completes, but ALSO wait until all
2211        the i/o completes...otherwise we'll be freeing the "info" structure
2212        that the i/o ASTs could still be using...
2213     */
2214
2215     while (!done) {
2216         _ckvmssts(sys$setast(0));
2217         done = info->done && info->in_done && info->out_done && info->err_done;
2218         if (!done) _ckvmssts(sys$clref(pipe_ef));
2219         _ckvmssts(sys$setast(1));
2220         if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2221     }
2222     retsts = info->completion;
2223
2224    /* remove from list of open pipes */
2225    _ckvmssts(sys$setast(0));
2226    if (last) last->next = info->next;
2227    else open_pipes = info->next;
2228    _ckvmssts(sys$setast(1));
2229
2230    /* free buffers and structures */
2231
2232    if (info->in) {
2233        if (info->in->buf) Safefree(info->in->buf);
2234        Safefree(info->in);
2235    }
2236    if (info->out) {
2237        if (info->out->buf) Safefree(info->out->buf);
2238        Safefree(info->out);
2239    }
2240    if (info->err) {
2241        if (info->err->buf) Safefree(info->err->buf);
2242        Safefree(info->err);
2243    }
2244    Safefree(info);
2245
2246    return retsts;
2247
2248}  /* end of my_pclose() */
2249
2250/* sort-of waitpid; use only with popen() */
2251/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2252Pid_t
2253my_waitpid(Pid_t pid, int *statusp, int flags)
2254{
2255    pInfo info;
2256    int done;
2257    dTHX;
2258   
2259    for (info = open_pipes; info != NULL; info = info->next)
2260        if (info->pid == pid) break;
2261
2262    if (info != NULL) {  /* we know about this child */
2263      while (!info->done) {
2264          _ckvmssts(sys$setast(0));
2265          done = info->done;
2266          if (!done) _ckvmssts(sys$clref(pipe_ef));
2267          _ckvmssts(sys$setast(1));
2268          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2269      }
2270
2271      *statusp = info->completion;
2272      return pid;
2273    }
2274    else {  /* we haven't heard of this child */
2275      $DESCRIPTOR(intdsc,"0 00:00:01");
2276      unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2277      unsigned long int interval[2],sts;
2278
2279      if (ckWARN(WARN_EXEC)) {
2280        _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2281        _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2282        if (ownerpid != mypid)
2283          Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2284      }
2285
2286      _ckvmssts(sys$bintim(&intdsc,interval));
2287      while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2288        _ckvmssts(sys$schdwk(0,0,interval,0));
2289        _ckvmssts(sys$hiber());
2290      }
2291      if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2292      _ckvmssts(sts);
2293
2294      /* There's no easy way to find the termination status a child we're
2295       * not aware of beforehand.  If we're really interested in the future,
2296       * we can go looking for a termination mailbox, or chase after the
2297       * accounting record for the process.
2298       */
2299      *statusp = 0;
2300      return pid;
2301    }
2302                   
2303}  /* end of waitpid() */
2304/*}}}*/
2305/*}}}*/
2306/*}}}*/
2307
2308/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2309char *
2310my_gconvert(double val, int ndig, int trail, char *buf)
2311{
2312  static char __gcvtbuf[DBL_DIG+1];
2313  char *loc;
2314
2315  loc = buf ? buf : __gcvtbuf;
2316
2317#ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2318  if (val < 1) {
2319    sprintf(loc,"%.*g",ndig,val);
2320    return loc;
2321  }
2322#endif
2323
2324  if (val) {
2325    if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2326    return gcvt(val,ndig,loc);
2327  }
2328  else {
2329    loc[0] = '0'; loc[1] = '\0';
2330    return loc;
2331  }
2332
2333}
2334/*}}}*/
2335
2336
2337/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2338/* Shortcut for common case of simple calls to $PARSE and $SEARCH
2339 * to expand file specification.  Allows for a single default file
2340 * specification and a simple mask of options.  If outbuf is non-NULL,
2341 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2342 * the resultant file specification is placed.  If outbuf is NULL, the
2343 * resultant file specification is placed into a static buffer.
2344 * The third argument, if non-NULL, is taken to be a default file
2345 * specification string.  The fourth argument is unused at present.
2346 * rmesexpand() returns the address of the resultant string if
2347 * successful, and NULL on error.
2348 */
2349static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2350
2351static char *
2352mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2353{
2354  static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2355  char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2356  char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2357  struct FAB myfab = cc$rms_fab;
2358  struct NAM mynam = cc$rms_nam;
2359  STRLEN speclen;
2360  unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2361
2362  if (!filespec || !*filespec) {
2363    set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2364    return NULL;
2365  }
2366  if (!outbuf) {
2367    if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2368    else    outbuf = __rmsexpand_retbuf;
2369  }
2370  if ((isunix = (strchr(filespec,'/') != NULL))) {
2371    if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2372    filespec = vmsfspec;
2373  }
2374
2375  myfab.fab$l_fna = filespec;
2376  myfab.fab$b_fns = strlen(filespec);
2377  myfab.fab$l_nam = &mynam;
2378
2379  if (defspec && *defspec) {
2380    if (strchr(defspec,'/') != NULL) {
2381      if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2382      defspec = tmpfspec;
2383    }
2384    myfab.fab$l_dna = defspec;
2385    myfab.fab$b_dns = strlen(defspec);
2386  }
2387
2388  mynam.nam$l_esa = esa;
2389  mynam.nam$b_ess = sizeof esa;
2390  mynam.nam$l_rsa = outbuf;
2391  mynam.nam$b_rss = NAM$C_MAXRSS;
2392
2393  retsts = sys$parse(&myfab,0,0);
2394  if (!(retsts & 1)) {
2395    mynam.nam$b_nop |= NAM$M_SYNCHK;
2396    if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2397      retsts = sys$parse(&myfab,0,0);
2398      if (retsts & 1) goto expanded;
2399    } 
2400    mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2401    (void) sys$parse(&myfab,0,0);  /* Free search context */
2402    if (out) Safefree(out);
2403    set_vaxc_errno(retsts);
2404    if      (retsts == RMS$_PRV) set_errno(EACCES);
2405    else if (retsts == RMS$_DEV) set_errno(ENODEV);
2406    else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2407    else                         set_errno(EVMSERR);
2408    return NULL;
2409  }
2410  retsts = sys$search(&myfab,0,0);
2411  if (!(retsts & 1) && retsts != RMS$_FNF) {
2412    mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2413    myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2414    if (out) Safefree(out);
2415    set_vaxc_errno(retsts);
2416    if      (retsts == RMS$_PRV) set_errno(EACCES);
2417    else                         set_errno(EVMSERR);
2418    return NULL;
2419  }
2420
2421  /* If the input filespec contained any lowercase characters,
2422   * downcase the result for compatibility with Unix-minded code. */
2423  expanded:
2424  for (out = myfab.fab$l_fna; *out; out++)
2425    if (islower(*out)) { haslower = 1; break; }
2426  if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2427  else                 { out = esa;    speclen = mynam.nam$b_esl; }
2428  /* Trim off null fields added by $PARSE
2429   * If type > 1 char, must have been specified in original or default spec
2430   * (not true for version; $SEARCH may have added version of existing file).
2431   */
2432  trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2433  trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2434             (mynam.nam$l_ver - mynam.nam$l_type == 1);
2435  if (trimver || trimtype) {
2436    if (defspec && *defspec) {
2437      char defesa[NAM$C_MAXRSS];
2438      struct FAB deffab = cc$rms_fab;
2439      struct NAM defnam = cc$rms_nam;
2440     
2441      deffab.fab$l_nam = &defnam;
2442      deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2443      defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2444      defnam.nam$b_nop = NAM$M_SYNCHK;
2445      if (sys$parse(&deffab,0,0) & 1) {
2446        if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2447        if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2448      }
2449    }
2450    if (trimver) speclen = mynam.nam$l_ver - out;
2451    if (trimtype) {
2452      /* If we didn't already trim version, copy down */
2453      if (speclen > mynam.nam$l_ver - out)
2454        memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2455               speclen - (mynam.nam$l_ver - out));
2456      speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2457    }
2458  }
2459  /* If we just had a directory spec on input, $PARSE "helpfully"
2460   * adds an empty name and type for us */
2461  if (mynam.nam$l_name == mynam.nam$l_type &&
2462      mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2463      !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2464    speclen = mynam.nam$l_name - out;
2465  out[speclen] = '\0';
2466  if (haslower) __mystrtolower(out);
2467
2468  /* Have we been working with an expanded, but not resultant, spec? */
2469  /* Also, convert back to Unix syntax if necessary. */
2470  if (!mynam.nam$b_rsl) {
2471    if (isunix) {
2472      if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2473    }
2474    else strcpy(outbuf,esa);
2475  }
2476  else if (isunix) {
2477    if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2478    strcpy(outbuf,tmpfspec);
2479  }
2480  mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2481  mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2482  myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2483  return outbuf;
2484}
2485/*}}}*/
2486/* External entry points */
2487char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2488{ return do_rmsexpand(spec,buf,0,def,opt); }
2489char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2490{ return do_rmsexpand(spec,buf,1,def,opt); }
2491
2492
2493/*
2494** The following routines are provided to make life easier when
2495** converting among VMS-style and Unix-style directory specifications.
2496** All will take input specifications in either VMS or Unix syntax. On
2497** failure, all return NULL.  If successful, the routines listed below
2498** return a pointer to a buffer containing the appropriately
2499** reformatted spec (and, therefore, subsequent calls to that routine
2500** will clobber the result), while the routines of the same names with
2501** a _ts suffix appended will return a pointer to a mallocd string
2502** containing the appropriately reformatted spec.
2503** In all cases, only explicit syntax is altered; no check is made that
2504** the resulting string is valid or that the directory in question
2505** actually exists.
2506**
2507**   fileify_dirspec() - convert a directory spec into the name of the
2508**     directory file (i.e. what you can stat() to see if it's a dir).
2509**     The style (VMS or Unix) of the result is the same as the style
2510**     of the parameter passed in.
2511**   pathify_dirspec() - convert a directory spec into a path (i.e.
2512**     what you prepend to a filename to indicate what directory it's in).
2513**     The style (VMS or Unix) of the result is the same as the style
2514**     of the parameter passed in.
2515**   tounixpath() - convert a directory spec into a Unix-style path.
2516**   tovmspath() - convert a directory spec into a VMS-style path.
2517**   tounixspec() - convert any file spec into a Unix-style file spec.
2518**   tovmsspec() - convert any file spec into a VMS-style spec.
2519**
2520** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2521** Permission is given to distribute this code as part of the Perl
2522** standard distribution under the terms of the GNU General Public
2523** License or the Perl Artistic License.  Copies of each may be
2524** found in the Perl standard distribution.
2525 */
2526
2527/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2528static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2529{
2530    static char __fileify_retbuf[NAM$C_MAXRSS+1];
2531    unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2532    char *retspec, *cp1, *cp2, *lastdir;
2533    char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2534
2535    if (!dir || !*dir) {
2536      set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2537    }
2538    dirlen = strlen(dir);
2539    while (dirlen && dir[dirlen-1] == '/') --dirlen;
2540    if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2541      strcpy(trndir,"/sys$disk/000000");
2542      dir = trndir;
2543      dirlen = 16;
2544    }
2545    if (dirlen > NAM$C_MAXRSS) {
2546      set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2547    }
2548    if (!strpbrk(dir+1,"/]>:")) {
2549      strcpy(trndir,*dir == '/' ? dir + 1: dir);
2550      while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2551      dir = trndir;
2552      dirlen = strlen(dir);
2553    }
2554    else {
2555      strncpy(trndir,dir,dirlen);
2556      trndir[dirlen] = '\0';
2557      dir = trndir;
2558    }
2559    /* If we were handed a rooted logical name or spec, treat it like a
2560     * simple directory, so that
2561     *    $ Define myroot dev:[dir.]
2562     *    ... do_fileify_dirspec("myroot",buf,1) ...
2563     * does something useful.
2564     */
2565    if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2566      dir[--dirlen] = '\0';
2567      dir[dirlen-1] = ']';
2568    }
2569
2570    if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2571      /* If we've got an explicit filename, we can just shuffle the string. */
2572      if (*(cp1+1)) hasfilename = 1;
2573      /* Similarly, we can just back up a level if we've got multiple levels
2574         of explicit directories in a VMS spec which ends with directories. */
2575      else {
2576        for (cp2 = cp1; cp2 > dir; cp2--) {
2577          if (*cp2 == '.') {
2578            *cp2 = *cp1; *cp1 = '\0';
2579            hasfilename = 1;
2580            break;
2581          }
2582          if (*cp2 == '[' || *cp2 == '<') break;
2583        }
2584      }
2585    }
2586
2587    if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2588      if (dir[0] == '.') {
2589        if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2590          return do_fileify_dirspec("[]",buf,ts);
2591        else if (dir[1] == '.' &&
2592                 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2593          return do_fileify_dirspec("[-]",buf,ts);
2594      }
2595      if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2596        dirlen -= 1;                 /* to last element */
2597        lastdir = strrchr(dir,'/');
2598      }
2599      else if ((cp1 = strstr(dir,"/.")) != NULL) {
2600        /* If we have "/." or "/..", VMSify it and let the VMS code
2601         * below expand it, rather than repeating the code to handle
2602         * relative components of a filespec here */
2603        do {
2604          if (*(cp1+2) == '.') cp1++;
2605          if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2606            if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2607            if (strchr(vmsdir,'/') != NULL) {
2608              /* If do_tovmsspec() returned it, it must have VMS syntax
2609               * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2610               * the time to check this here only so we avoid a recursion
2611               * loop; otherwise, gigo.
2612               */
2613              set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2614            }
2615            if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2616            return do_tounixspec(trndir,buf,ts);
2617          }
2618          cp1++;
2619        } while ((cp1 = strstr(cp1,"/.")) != NULL);
2620        lastdir = strrchr(dir,'/');
2621      }
2622      else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2623        /* Ditto for specs that end in an MFD -- let the VMS code
2624         * figure out whether it's a real device or a rooted logical. */
2625        dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2626        if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2627        if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2628        return do_tounixspec(trndir,buf,ts);
2629      }
2630      else {
2631        if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2632             !(lastdir = cp1 = strrchr(dir,']')) &&
2633             !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2634        if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2635          int ver; char *cp3;
2636          if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2637              !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2638              !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2639              (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2640              (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2641                            (ver || *cp3)))))) {
2642            set_errno(ENOTDIR);
2643            set_vaxc_errno(RMS$_DIR);
2644            return NULL;
2645          }
2646          dirlen = cp2 - dir;
2647        }
2648      }
2649      /* If we lead off with a device or rooted logical, add the MFD
2650         if we're specifying a top-level directory. */
2651      if (lastdir && *dir == '/') {
2652        addmfd = 1;
2653        for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2654          if (*cp1 == '/') {
2655            addmfd = 0;
2656            break;
2657          }
2658        }
2659      }
2660      retlen = dirlen + (addmfd ? 13 : 6);
2661      if (buf) retspec = buf;
2662      else if (ts) New(1309,retspec,retlen+1,char);
2663      else retspec = __fileify_retbuf;
2664      if (addmfd) {
2665        dirlen = lastdir - dir;
2666        memcpy(retspec,dir,dirlen);
2667        strcpy(&retspec[dirlen],"/000000");
2668        strcpy(&retspec[dirlen+7],lastdir);
2669      }
2670      else {
2671        memcpy(retspec,dir,dirlen);
2672        retspec[dirlen] = '\0';
2673      }
2674      /* We've picked up everything up to the directory file name.
2675         Now just add the type and version, and we're set. */
2676      strcat(retspec,".dir;1");
2677      return retspec;
2678    }
2679    else {  /* VMS-style directory spec */
2680      char esa[NAM$C_MAXRSS+1], term, *cp;
2681      unsigned long int sts, cmplen, haslower = 0;
2682      struct FAB dirfab = cc$rms_fab;
2683      struct NAM savnam, dirnam = cc$rms_nam;
2684
2685      dirfab.fab$b_fns = strlen(dir);
2686      dirfab.fab$l_fna = dir;
2687      dirfab.fab$l_nam = &dirnam;
2688      dirfab.fab$l_dna = ".DIR;1";
2689      dirfab.fab$b_dns = 6;
2690      dirnam.nam$b_ess = NAM$C_MAXRSS;
2691      dirnam.nam$l_esa = esa;
2692
2693      for (cp = dir; *cp; cp++)
2694        if (islower(*cp)) { haslower = 1; break; }
2695      if (!((sts = sys$parse(&dirfab))&1)) {
2696        if (dirfab.fab$l_sts == RMS$_DIR) {
2697          dirnam.nam$b_nop |= NAM$M_SYNCHK;
2698          sts = sys$parse(&dirfab) & 1;
2699        }
2700        if (!sts) {
2701          set_errno(EVMSERR);
2702          set_vaxc_errno(dirfab.fab$l_sts);
2703          return NULL;
2704        }
2705      }
2706      else {
2707        savnam = dirnam;
2708        if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
2709          /* Yes; fake the fnb bits so we'll check type below */
2710          dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2711        }
2712        else { /* No; just work with potential name */
2713          if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2714          else {
2715            set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
2716            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2717            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2718            return NULL;
2719          }
2720        }
2721      }
2722      if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2723        cp1 = strchr(esa,']');
2724        if (!cp1) cp1 = strchr(esa,'>');
2725        if (cp1) {  /* Should always be true */
2726          dirnam.nam$b_esl -= cp1 - esa - 1;
2727          memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2728        }
2729      }
2730      if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
2731        /* Yep; check version while we're at it, if it's there. */
2732        cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2733        if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2734          /* Something other than .DIR[;1].  Bzzt. */
2735          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2736          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2737          set_errno(ENOTDIR);
2738          set_vaxc_errno(RMS$_DIR);
2739          return NULL;
2740        }
2741      }
2742      esa[dirnam.nam$b_esl] = '\0';
2743      if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2744        /* They provided at least the name; we added the type, if necessary, */
2745        if (buf) retspec = buf;                            /* in sys$parse() */
2746        else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2747        else retspec = __fileify_retbuf;
2748        strcpy(retspec,esa);
2749        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2750        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2751        return retspec;
2752      }
2753      if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2754        for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2755        *cp1 = '\0';
2756        dirnam.nam$b_esl -= 9;
2757      }
2758      if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2759      if (cp1 == NULL) { /* should never happen */
2760        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2761        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2762        return NULL;
2763      }
2764      term = *cp1;
2765      *cp1 = '\0';
2766      retlen = strlen(esa);
2767      if ((cp1 = strrchr(esa,'.')) != NULL) {
2768        /* There's more than one directory in the path.  Just roll back. */
2769        *cp1 = term;
2770        if (buf) retspec = buf;
2771        else if (ts) New(1311,retspec,retlen+7,char);
2772        else retspec = __fileify_retbuf;
2773        strcpy(retspec,esa);
2774      }
2775      else {
2776        if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2777          /* Go back and expand rooted logical name */
2778          dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2779          if (!(sys$parse(&dirfab) & 1)) {
2780            dirnam.nam$l_rlf = NULL;
2781            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2782            set_errno(EVMSERR);
2783            set_vaxc_errno(dirfab.fab$l_sts);
2784            return NULL;
2785          }
2786          retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2787          if (buf) retspec = buf;
2788          else if (ts) New(1312,retspec,retlen+16,char);
2789          else retspec = __fileify_retbuf;
2790          cp1 = strstr(esa,"][");
2791          dirlen = cp1 - esa;
2792          memcpy(retspec,esa,dirlen);
2793          if (!strncmp(cp1+2,"000000]",7)) {
2794            retspec[dirlen-1] = '\0';
2795            for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2796            if (*cp1 == '.') *cp1 = ']';
2797            else {
2798              memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2799              memcpy(cp1+1,"000000]",7);
2800            }
2801          }
2802          else {
2803            memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2804            retspec[retlen] = '\0';
2805            /* Convert last '.' to ']' */
2806            for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2807            if (*cp1 == '.') *cp1 = ']';
2808            else {
2809              memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2810              memcpy(cp1+1,"000000]",7);
2811            }
2812          }
2813        }
2814        else {  /* This is a top-level dir.  Add the MFD to the path. */
2815          if (buf) retspec = buf;
2816          else if (ts) New(1312,retspec,retlen+16,char);
2817          else retspec = __fileify_retbuf;
2818          cp1 = esa;
2819          cp2 = retspec;
2820          while (*cp1 != ':') *(cp2++) = *(cp1++);
2821          strcpy(cp2,":[000000]");
2822          cp1 += 2;
2823          strcpy(cp2+9,cp1);
2824        }
2825      }
2826      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2827      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2828      /* We've set up the string up through the filename.  Add the
2829         type and version, and we're done. */
2830      strcat(retspec,".DIR;1");
2831
2832      /* $PARSE may have upcased filespec, so convert output to lower
2833       * case if input contained any lowercase characters. */
2834      if (haslower) __mystrtolower(retspec);
2835      return retspec;
2836    }
2837}  /* end of do_fileify_dirspec() */
2838/*}}}*/
2839/* External entry points */
2840char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2841{ return do_fileify_dirspec(dir,buf,0); }
2842char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2843{ return do_fileify_dirspec(dir,buf,1); }
2844
2845/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2846static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2847{
2848    static char __pathify_retbuf[NAM$C_MAXRSS+1];
2849    unsigned long int retlen;
2850    char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2851
2852    if (!dir || !*dir) {
2853      set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2854    }
2855
2856    if (*dir) strcpy(trndir,dir);
2857    else getcwd(trndir,sizeof trndir - 1);
2858
2859    while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2860           && my_trnlnm(trndir,trndir,0)) {
2861      STRLEN trnlen = strlen(trndir);
2862
2863      /* Trap simple rooted lnms, and return lnm:[000000] */
2864      if (!strcmp(trndir+trnlen-2,".]")) {
2865        if (buf) retpath = buf;
2866        else if (ts) New(1318,retpath,strlen(dir)+10,char);
2867        else retpath = __pathify_retbuf;
2868        strcpy(retpath,dir);
2869        strcat(retpath,":[000000]");
2870        return retpath;
2871      }
2872    }
2873    dir = trndir;
2874
2875    if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2876      if (*dir == '.' && (*(dir+1) == '\0' ||
2877                          (*(dir+1) == '.' && *(dir+2) == '\0')))
2878        retlen = 2 + (*(dir+1) != '\0');
2879      else {
2880        if ( !(cp1 = strrchr(dir,'/')) &&
2881             !(cp1 = strrchr(dir,']')) &&
2882             !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2883        if ((cp2 = strchr(cp1,'.')) != NULL &&
2884            (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
2885             !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
2886              (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2887              (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2888          int ver; char *cp3;
2889          if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2890              !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2891              !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2892              (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2893              (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2894                            (ver || *cp3)))))) {
2895            set_errno(ENOTDIR);
2896            set_vaxc_errno(RMS$_DIR);
2897            return NULL;
2898          }
2899          retlen = cp2 - dir + 1;
2900        }
2901        else {  /* No file type present.  Treat the filename as a directory. */
2902          retlen = strlen(dir) + 1;
2903        }
2904      }
2905      if (buf) retpath = buf;
2906      else if (ts) New(1313,retpath,retlen+1,char);
2907      else retpath = __pathify_retbuf;
2908      strncpy(retpath,dir,retlen-1);
2909      if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2910        retpath[retlen-1] = '/';      /* with '/', add it. */
2911        retpath[retlen] = '\0';
2912      }
2913      else retpath[retlen-1] = '\0';
2914    }
2915    else {  /* VMS-style directory spec */
2916      char esa[NAM$C_MAXRSS+1], *cp;
2917      unsigned long int sts, cmplen, haslower;
2918      struct FAB dirfab = cc$rms_fab;
2919      struct NAM savnam, dirnam = cc$rms_nam;
2920
2921      /* If we've got an explicit filename, we can just shuffle the string. */
2922      if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2923             (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
2924        if ((cp2 = strchr(cp1,'.')) != NULL) {
2925          int ver; char *cp3;
2926          if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2927              !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2928              !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2929              (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2930              (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2931                            (ver || *cp3)))))) {
2932            set_errno(ENOTDIR);
2933            set_vaxc_errno(RMS$_DIR);
2934            return NULL;
2935          }
2936        }
2937        else {  /* No file type, so just draw name into directory part */
2938          for (cp2 = cp1; *cp2; cp2++) ;
2939        }
2940        *cp2 = *cp1;
2941        *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
2942        *cp1 = '.';
2943        /* We've now got a VMS 'path'; fall through */
2944      }
2945      dirfab.fab$b_fns = strlen(dir);
2946      dirfab.fab$l_fna = dir;
2947      if (dir[dirfab.fab$b_fns-1] == ']' ||
2948          dir[dirfab.fab$b_fns-1] == '>' ||
2949          dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2950        if (buf) retpath = buf;
2951        else if (ts) New(1314,retpath,strlen(dir)+1,char);
2952        else retpath = __pathify_retbuf;
2953        strcpy(retpath,dir);
2954        return retpath;
2955      }
2956      dirfab.fab$l_dna = ".DIR;1";
2957      dirfab.fab$b_dns = 6;
2958      dirfab.fab$l_nam = &dirnam;
2959      dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2960      dirnam.nam$l_esa = esa;
2961
2962      for (cp = dir; *cp; cp++)
2963        if (islower(*cp)) { haslower = 1; break; }
2964
2965      if (!(sts = (sys$parse(&dirfab)&1))) {
2966        if (dirfab.fab$l_sts == RMS$_DIR) {
2967          dirnam.nam$b_nop |= NAM$M_SYNCHK;
2968          sts = sys$parse(&dirfab) & 1;
2969        }
2970        if (!sts) {
2971          set_errno(EVMSERR);
2972          set_vaxc_errno(dirfab.fab$l_sts);
2973          return NULL;
2974        }
2975      }
2976      else {
2977        savnam = dirnam;
2978        if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
2979          if (dirfab.fab$l_sts != RMS$_FNF) {
2980            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2981            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2982            set_errno(EVMSERR);
2983            set_vaxc_errno(dirfab.fab$l_sts);
2984            return NULL;
2985          }
2986          dirnam = savnam; /* No; just work with potential name */
2987        }
2988      }
2989      if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
2990        /* Yep; check version while we're at it, if it's there. */
2991        cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2992        if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2993          /* Something other than .DIR[;1].  Bzzt. */
2994          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2995          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2996          set_errno(ENOTDIR);
2997          set_vaxc_errno(RMS$_DIR);
2998          return NULL;
2999        }
3000      }
3001      /* OK, the type was fine.  Now pull any file name into the
3002         directory path. */
3003      if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3004      else {
3005        cp1 = strrchr(esa,'>');
3006        *dirnam.nam$l_type = '>';
3007      }
3008      *cp1 = '.';
3009      *(dirnam.nam$l_type + 1) = '\0';
3010      retlen = dirnam.nam$l_type - esa + 2;
3011      if (buf) retpath = buf;
3012      else if (ts) New(1314,retpath,retlen,char);
3013      else retpath = __pathify_retbuf;
3014      strcpy(retpath,esa);
3015      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3016      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3017      /* $PARSE may have upcased filespec, so convert output to lower
3018       * case if input contained any lowercase characters. */
3019      if (haslower) __mystrtolower(retpath);
3020    }
3021
3022    return retpath;
3023}  /* end of do_pathify_dirspec() */
3024/*}}}*/
3025/* External entry points */
3026char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3027{ return do_pathify_dirspec(dir,buf,0); }
3028char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3029{ return do_pathify_dirspec(dir,buf,1); }
3030
3031/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3032static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3033{
3034  static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3035  char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3036  int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3037
3038  if (spec == NULL) return NULL;
3039  if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3040  if (buf) rslt = buf;
3041  else if (ts) {
3042    retlen = strlen(spec);
3043    cp1 = strchr(spec,'[');
3044    if (!cp1) cp1 = strchr(spec,'<');
3045    if (cp1) {
3046      for (cp1++; *cp1; cp1++) {
3047        if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3048        if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3049          { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3050      }
3051    }
3052    New(1315,rslt,retlen+2+2*expand,char);
3053  }
3054  else rslt = __tounixspec_retbuf;
3055  if (strchr(spec,'/') != NULL) {
3056    strcpy(rslt,spec);
3057    return rslt;
3058  }
3059
3060  cp1 = rslt;
3061  cp2 = spec;
3062  dirend = strrchr(spec,']');
3063  if (dirend == NULL) dirend = strrchr(spec,'>');
3064  if (dirend == NULL) dirend = strchr(spec,':');
3065  if (dirend == NULL) {
3066    strcpy(rslt,spec);
3067    return rslt;
3068  }
3069  if (*cp2 != '[' && *cp2 != '<') {
3070    *(cp1++) = '/';
3071  }
3072  else {  /* the VMS spec begins with directories */
3073    cp2++;
3074    if (*cp2 == ']' || *cp2 == '>') {
3075      *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3076      return rslt;
3077    }
3078    else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3079      if (getcwd(tmp,sizeof tmp,1) == NULL) {
3080        if (ts) Safefree(rslt);
3081        return NULL;
3082      }
3083      do {
3084        cp3 = tmp;
3085        while (*cp3 != ':' && *cp3) cp3++;
3086        *(cp3++) = '\0';
3087        if (strchr(cp3,']') != NULL) break;
3088      } while (vmstrnenv(tmp,tmp,0,fildev,0));
3089      if (ts && !buf &&
3090          ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3091        retlen = devlen + dirlen;
3092        Renew(rslt,retlen+1+2*expand,char);
3093        cp1 = rslt;
3094      }
3095      cp3 = tmp;
3096      *(cp1++) = '/';
3097      while (*cp3) {
3098        *(cp1++) = *(cp3++);
3099        if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3100      }
3101      *(cp1++) = '/';
3102    }
3103    else if ( *cp2 == '.') {
3104      if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3105        *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3106        cp2 += 3;
3107      }
3108      else cp2++;
3109    }
3110  }
3111  for (; cp2 <= dirend; cp2++) {
3112    if (*cp2 == ':') {
3113      *(cp1++) = '/';
3114      if (*(cp2+1) == '[') cp2++;
3115    }
3116    else if (*cp2 == ']' || *cp2 == '>') {
3117      if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3118    }
3119    else if (*cp2 == '.') {
3120      *(cp1++) = '/';
3121      if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3122        while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3123               *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3124        if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3125            *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3126      }
3127      else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3128        *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3129        cp2 += 2;
3130      }
3131    }
3132    else if (*cp2 == '-') {
3133      if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3134        while (*cp2 == '-') {
3135          cp2++;
3136          *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3137        }
3138        if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3139          if (ts) Safefree(rslt);                        /* filespecs like */
3140          set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3141          return NULL;
3142        }
3143      }
3144      else *(cp1++) = *cp2;
3145    }
3146    else *(cp1++) = *cp2;
3147  }
3148  while (*cp2) *(cp1++) = *(cp2++);
3149  *cp1 = '\0';
3150
3151  return rslt;
3152
3153}  /* end of do_tounixspec() */
3154/*}}}*/
3155/* External entry points */
3156char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3157char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3158
3159/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3160static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3161  static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3162  char *rslt, *dirend;
3163  register char *cp1, *cp2;
3164  unsigned long int infront = 0, hasdir = 1;
3165
3166  if (path == NULL) return NULL;
3167  if (buf) rslt = buf;
3168  else if (ts) New(1316,rslt,strlen(path)+9,char);
3169  else rslt = __tovmsspec_retbuf;
3170  if (strpbrk(path,"]:>") ||
3171      (dirend = strrchr(path,'/')) == NULL) {
3172    if (path[0] == '.') {
3173      if (path[1] == '\0') strcpy(rslt,"[]");
3174      else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3175      else strcpy(rslt,path); /* probably garbage */
3176    }
3177    else strcpy(rslt,path);
3178    return rslt;
3179  }
3180  if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3181    if (!*(dirend+2)) dirend +=2;
3182    if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3183    if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3184  }
3185  cp1 = rslt;
3186  cp2 = path;
3187  if (*cp2 == '/') {
3188    char trndev[NAM$C_MAXRSS+1];
3189    int islnm, rooted;
3190    STRLEN trnend;
3191
3192    while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3193    if (!*(cp2+1)) {
3194      if (!buf & ts) Renew(rslt,18,char);
3195      strcpy(rslt,"sys$disk:[000000]");
3196      return rslt;
3197    }
3198    while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3199    *cp1 = '\0';
3200    islnm =  my_trnlnm(rslt,trndev,0);
3201    trnend = islnm ? strlen(trndev) - 1 : 0;
3202    islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3203    rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3204    /* If the first element of the path is a logical name, determine
3205     * whether it has to be translated so we can add more directories. */
3206    if (!islnm || rooted) {
3207      *(cp1++) = ':';
3208      *(cp1++) = '[';
3209      if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3210      else cp2++;
3211    }
3212    else {
3213      if (cp2 != dirend) {
3214        if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3215        strcpy(rslt,trndev);
3216        cp1 = rslt + trnend;
3217        *(cp1++) = '.';
3218        cp2++;
3219      }
3220      else {
3221        *(cp1++) = ':';
3222        hasdir = 0;
3223      }
3224    }
3225  }
3226  else {
3227    *(cp1++) = '[';
3228    if (*cp2 == '.') {
3229      if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3230        cp2 += 2;         /* skip over "./" - it's redundant */
3231        *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3232      }
3233      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3234        *(cp1++) = '-';                                 /* "../" --> "-" */
3235        cp2 += 3;
3236      }
3237      else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3238               (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3239        *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3240        if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3241        cp2 += 4;
3242      }
3243      if (cp2 > dirend) cp2 = dirend;
3244    }
3245    else *(cp1++) = '.';
3246  }
3247  for (; cp2 < dirend; cp2++) {
3248    if (*cp2 == '/') {
3249      if (*(cp2-1) == '/') continue;
3250      if (*(cp1-1) != '.') *(cp1++) = '.';
3251      infront = 0;
3252    }
3253    else if (!infront && *cp2 == '.') {
3254      if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3255      else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3256      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3257        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3258        else if (*(cp1-2) == '[') *(cp1-1) = '-';
3259        else {  /* back up over previous directory name */
3260          cp1--;
3261          while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3262          if (*(cp1-1) == '[') {
3263            memcpy(cp1,"000000.",7);
3264            cp1 += 7;
3265          }
3266        }
3267        cp2 += 2;
3268        if (cp2 == dirend) break;
3269      }
3270      else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3271                (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3272        if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3273        *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3274        if (!*(cp2+3)) {
3275          *(cp1++) = '.';  /* Simulate trailing '/' */
3276          cp2 += 2;  /* for loop will incr this to == dirend */
3277        }
3278        else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3279      }
3280      else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3281    }
3282    else {
3283      if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3284      if (*cp2 == '.')      *(cp1++) = '_';
3285      else                  *(cp1++) =  *cp2;
3286      infront = 1;
3287    }
3288  }
3289  if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3290  if (hasdir) *(cp1++) = ']';
3291  if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3292  while (*cp2) *(cp1++) = *(cp2++);
3293  *cp1 = '\0';
3294
3295  return rslt;
3296
3297}  /* end of do_tovmsspec() */
3298/*}}}*/
3299/* External entry points */
3300char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3301char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3302
3303/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3304static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3305  static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3306  int vmslen;
3307  char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3308
3309  if (path == NULL) return NULL;
3310  if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3311  if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3312  if (buf) return buf;
3313  else if (ts) {
3314    vmslen = strlen(vmsified);
3315    New(1317,cp,vmslen+1,char);
3316    memcpy(cp,vmsified,vmslen);
3317    cp[vmslen] = '\0';
3318    return cp;
3319  }
3320  else {
3321    strcpy(__tovmspath_retbuf,vmsified);
3322    return __tovmspath_retbuf;
3323  }
3324
3325}  /* end of do_tovmspath() */
3326/*}}}*/
3327/* External entry points */
3328char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3329char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3330
3331
3332/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3333static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3334  static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3335  int unixlen;
3336  char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3337
3338  if (path == NULL) return NULL;
3339  if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3340  if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3341  if (buf) return buf;
3342  else if (ts) {
3343    unixlen = strlen(unixified);
3344    New(1317,cp,unixlen+1,char);
3345    memcpy(cp,unixified,unixlen);
3346    cp[unixlen] = '\0';
3347    return cp;
3348  }
3349  else {
3350    strcpy(__tounixpath_retbuf,unixified);
3351    return __tounixpath_retbuf;
3352  }
3353
3354}  /* end of do_tounixpath() */
3355/*}}}*/
3356/* External entry points */
3357char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3358char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3359
3360/*
3361 * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3362 *
3363 *****************************************************************************
3364 *                                                                           *
3365 *  Copyright (C) 1989-1994 by                                               *
3366 *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3367 *                                                                           *
3368 *  Permission is hereby  granted for the reproduction of this software,     *
3369 *  on condition that this copyright notice is included in the reproduction, *
3370 *  and that such reproduction is not for purposes of profit or material     *
3371 *  gain.                                                                    *
3372 *                                                                           *
3373 *  27-Aug-1994 Modified for inclusion in perl5                              *
3374 *              by Charles Bailey  bailey@newman.upenn.edu                   *
3375 *****************************************************************************
3376 */
3377
3378/*
3379 * getredirection() is intended to aid in porting C programs
3380 * to VMS (Vax-11 C).  The native VMS environment does not support
3381 * '>' and '<' I/O redirection, or command line wild card expansion,
3382 * or a command line pipe mechanism using the '|' AND background
3383 * command execution '&'.  All of these capabilities are provided to any
3384 * C program which calls this procedure as the first thing in the
3385 * main program.
3386 * The piping mechanism will probably work with almost any 'filter' type
3387 * of program.  With suitable modification, it may useful for other
3388 * portability problems as well.
3389 *
3390 * Author:  Mark Pizzolato      mark@infocomm.com
3391 */
3392struct list_item
3393    {
3394    struct list_item *next;
3395    char *value;
3396    };
3397
3398static void add_item(struct list_item **head,
3399                     struct list_item **tail,
3400                     char *value,
3401                     int *count);
3402
3403static void mp_expand_wild_cards(pTHX_ char *item,
3404                                struct list_item **head,
3405                                struct list_item **tail,
3406                                int *count);
3407
3408static int background_process(int argc, char **argv);
3409
3410static void pipe_and_fork(char **cmargv);
3411
3412/*{{{ void getredirection(int *ac, char ***av)*/
3413static void
3414mp_getredirection(pTHX_ int *ac, char ***av)
3415/*
3416 * Process vms redirection arg's.  Exit if any error is seen.
3417 * If getredirection() processes an argument, it is erased
3418 * from the vector.  getredirection() returns a new argc and argv value.
3419 * In the event that a background command is requested (by a trailing "&"),
3420 * this routine creates a background subprocess, and simply exits the program.
3421 *
3422 * Warning: do not try to simplify the code for vms.  The code
3423 * presupposes that getredirection() is called before any data is
3424 * read from stdin or written to stdout.
3425 *
3426 * Normal usage is as follows:
3427 *
3428 *      main(argc, argv)
3429 *      int             argc;
3430 *      char            *argv[];
3431 *      {
3432 *              getredirection(&argc, &argv);
3433 *      }
3434 */
3435{
3436    int                 argc = *ac;     /* Argument Count         */
3437    char                **argv = *av;   /* Argument Vector        */
3438    char                *ap;            /* Argument pointer       */
3439    int                 j;              /* argv[] index           */
3440    int                 item_count = 0; /* Count of Items in List */
3441    struct list_item    *list_head = 0; /* First Item in List       */
3442    struct list_item    *list_tail;     /* Last Item in List        */
3443    char                *in = NULL;     /* Input File Name          */
3444    char                *out = NULL;    /* Output File Name         */
3445    char                *outmode = "w"; /* Mode to Open Output File */
3446    char                *err = NULL;    /* Error File Name          */
3447    char                *errmode = "w"; /* Mode to Open Error File  */
3448    int                 cmargc = 0;     /* Piped Command Arg Count  */
3449    char                **cmargv = NULL;/* Piped Command Arg Vector */
3450
3451    /*
3452     * First handle the case where the last thing on the line ends with
3453     * a '&'.  This indicates the desire for the command to be run in a
3454     * subprocess, so we satisfy that desire.
3455     */
3456    ap = argv[argc-1];
3457    if (0 == strcmp("&", ap))
3458        exit(background_process(--argc, argv));
3459    if (*ap && '&' == ap[strlen(ap)-1])
3460        {
3461        ap[strlen(ap)-1] = '\0';
3462        exit(background_process(argc, argv));
3463        }
3464    /*
3465     * Now we handle the general redirection cases that involve '>', '>>',
3466     * '<', and pipes '|'.
3467     */
3468    for (j = 0; j < argc; ++j)
3469        {
3470        if (0 == strcmp("<", argv[j]))
3471            {
3472            if (j+1 >= argc)
3473                {
3474                PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3475                exit(LIB$_WRONUMARG);
3476                }
3477            in = argv[++j];
3478            continue;
3479            }
3480        if ('<' == *(ap = argv[j]))
3481            {
3482            in = 1 + ap;
3483            continue;
3484            }
3485        if (0 == strcmp(">", ap))
3486            {
3487            if (j+1 >= argc)
3488                {
3489                PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3490                exit(LIB$_WRONUMARG);
3491                }
3492            out = argv[++j];
3493            continue;
3494            }
3495        if ('>' == *ap)
3496            {
3497            if ('>' == ap[1])
3498                {
3499                outmode = "a";
3500                if ('\0' == ap[2])
3501                    out = argv[++j];
3502                else
3503                    out = 2 + ap;
3504                }
3505            else
3506                out = 1 + ap;
3507            if (j >= argc)
3508                {
3509                PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3510                exit(LIB$_WRONUMARG);
3511                }
3512            continue;
3513            }
3514        if (('2' == *ap) && ('>' == ap[1]))
3515            {
3516            if ('>' == ap[2])
3517                {
3518                errmode = "a";
3519                if ('\0' == ap[3])
3520                    err = argv[++j];
3521                else
3522                    err = 3 + ap;
3523                }
3524            else
3525                if ('\0' == ap[2])
3526                    err = argv[++j];
3527                else
3528                    err = 2 + ap;
3529            if (j >= argc)
3530                {
3531                PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3532                exit(LIB$_WRONUMARG);
3533                }
3534            continue;
3535            }
3536        if (0 == strcmp("|", argv[j]))
3537            {
3538            if (j+1 >= argc)
3539                {
3540                PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3541                exit(LIB$_WRONUMARG);
3542                }
3543            cmargc = argc-(j+1);
3544            cmargv = &argv[j+1];
3545            argc = j;
3546            continue;
3547            }
3548        if ('|' == *(ap = argv[j]))
3549            {
3550            ++argv[j];
3551            cmargc = argc-j;
3552            cmargv = &argv[j];
3553            argc = j;
3554            continue;
3555            }
3556        expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3557        }
3558    /*
3559     * Allocate and fill in the new argument vector, Some Unix's terminate
3560     * the list with an extra null pointer.
3561     */
3562    New(1302, argv, item_count+1, char *);
3563    *av = argv;
3564    for (j = 0; j < item_count; ++j, list_head = list_head->next)
3565        argv[j] = list_head->value;
3566    *ac = item_count;
3567    if (cmargv != NULL)
3568        {
3569        if (out != NULL)
3570            {
3571            PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3572            exit(LIB$_INVARGORD);
3573            }
3574        pipe_and_fork(cmargv);
3575        }
3576       
3577    /* Check for input from a pipe (mailbox) */
3578
3579    if (in == NULL && 1 == isapipe(0))
3580        {
3581        char mbxname[L_tmpnam];
3582        long int bufsize;
3583        long int dvi_item = DVI$_DEVBUFSIZ;
3584        $DESCRIPTOR(mbxnam, "");
3585        $DESCRIPTOR(mbxdevnam, "");
3586
3587        /* Input from a pipe, reopen it in binary mode to disable       */
3588        /* carriage control processing.                                 */
3589
3590        PerlIO_getname(stdin, mbxname);
3591        mbxnam.dsc$a_pointer = mbxname;
3592        mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);     
3593        lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3594        mbxdevnam.dsc$a_pointer = mbxname;
3595        mbxdevnam.dsc$w_length = sizeof(mbxname);
3596        dvi_item = DVI$_DEVNAM;
3597        lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3598        mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3599        set_errno(0);
3600        set_vaxc_errno(1);
3601        freopen(mbxname, "rb", stdin);
3602        if (errno != 0)
3603            {
3604            PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3605            exit(vaxc$errno);
3606            }
3607        }
3608    if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3609        {
3610        PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3611        exit(vaxc$errno);
3612        }
3613    if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3614        {       
3615        PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3616        exit(vaxc$errno);
3617        }
3618        if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
3619
3620    if (err != NULL) {
3621        if (strcmp(err,"&1") == 0) {
3622            dup2(fileno(stdout), fileno(Perl_debug_log));
3623            Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
3624        } else {
3625        FILE *tmperr;
3626        if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3627            {
3628            PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3629            exit(vaxc$errno);
3630            }
3631            fclose(tmperr);
3632            if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3633                {
3634                exit(vaxc$errno);
3635                }
3636            Perl_vmssetuserlnm("SYS$ERROR",err);
3637        }
3638        }
3639#ifdef ARGPROC_DEBUG
3640    PerlIO_printf(Perl_debug_log, "Arglist:\n");
3641    for (j = 0; j < *ac;  ++j)
3642        PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3643#endif
3644   /* Clear errors we may have hit expanding wildcards, so they don't
3645      show up in Perl's $! later */
3646   set_errno(0); set_vaxc_errno(1);
3647}  /* end of getredirection() */
3648/*}}}*/
3649
3650static void add_item(struct list_item **head,
3651                     struct list_item **tail,
3652                     char *value,
3653                     int *count)
3654{
3655    if (*head == 0)
3656        {
3657        New(1303,*head,1,struct list_item);
3658        *tail = *head;
3659        }
3660    else {
3661        New(1304,(*tail)->next,1,struct list_item);
3662        *tail = (*tail)->next;
3663        }
3664    (*tail)->value = value;
3665    ++(*count);
3666}
3667
3668static void mp_expand_wild_cards(pTHX_ char *item,
3669                              struct list_item **head,
3670                              struct list_item **tail,
3671                              int *count)
3672{
3673int expcount = 0;
3674unsigned long int context = 0;
3675int isunix = 0;
3676char *had_version;
3677char *had_device;
3678int had_directory;
3679char *devdir,*cp;
3680char vmsspec[NAM$C_MAXRSS+1];
3681$DESCRIPTOR(filespec, "");
3682$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3683$DESCRIPTOR(resultspec, "");
3684unsigned long int zero = 0, sts;
3685
3686    for (cp = item; *cp; cp++) {
3687        if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3688        if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3689    }
3690    if (!*cp || isspace(*cp))
3691        {
3692        add_item(head, tail, item, count);
3693        return;
3694        }
3695    resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3696    resultspec.dsc$b_class = DSC$K_CLASS_D;
3697    resultspec.dsc$a_pointer = NULL;
3698    if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3699      filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3700    if (!isunix || !filespec.dsc$a_pointer)
3701      filespec.dsc$a_pointer = item;
3702    filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3703    /*
3704     * Only return version specs, if the caller specified a version
3705     */
3706    had_version = strchr(item, ';');
3707    /*
3708     * Only return device and directory specs, if the caller specifed either.
3709     */
3710    had_device = strchr(item, ':');
3711    had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3712   
3713    while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3714                                  &defaultspec, 0, 0, &zero))))
3715        {
3716        char *string;
3717        char *c;
3718
3719        New(1305,string,resultspec.dsc$w_length+1,char);
3720        strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3721        string[resultspec.dsc$w_length] = '\0';
3722        if (NULL == had_version)
3723            *((char *)strrchr(string, ';')) = '\0';
3724        if ((!had_directory) && (had_device == NULL))
3725            {
3726            if (NULL == (devdir = strrchr(string, ']')))
3727                devdir = strrchr(string, '>');
3728            strcpy(string, devdir + 1);
3729            }
3730        /*
3731         * Be consistent with what the C RTL has already done to the rest of
3732         * the argv items and lowercase all of these names.
3733         */
3734        for (c = string; *c; ++c)
3735            if (isupper(*c))
3736                *c = tolower(*c);
3737        if (isunix) trim_unixpath(string,item,1);
3738        add_item(head, tail, string, count);
3739        ++expcount;
3740        }
3741    if (sts != RMS$_NMF)
3742        {
3743        set_vaxc_errno(sts);
3744        switch (sts)
3745            {
3746            case RMS$_FNF: case RMS$_DNF:
3747                set_errno(ENOENT); break;
3748            case RMS$_DIR:
3749                set_errno(ENOTDIR); break;
3750            case RMS$_DEV:
3751                set_errno(ENODEV); break;
3752            case RMS$_FNM: case RMS$_SYN:
3753                set_errno(EINVAL); break;
3754            case RMS$_PRV:
3755                set_errno(EACCES); break;
3756            default:
3757                _ckvmssts_noperl(sts);
3758            }
3759        }
3760    if (expcount == 0)
3761        add_item(head, tail, item, count);
3762    _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3763    _ckvmssts_noperl(lib$find_file_end(&context));
3764}
3765
3766static int child_st[2];/* Event Flag set when child process completes   */
3767
3768static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
3769
3770static unsigned long int exit_handler(int *status)
3771{
3772short iosb[4];
3773
3774    if (0 == child_st[0])
3775        {
3776#ifdef ARGPROC_DEBUG
3777        PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3778#endif
3779        fflush(stdout);     /* Have to flush pipe for binary data to    */
3780                            /* terminate properly -- <tp@mccall.com>    */
3781        sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3782        sys$dassgn(child_chan);
3783        fclose(stdout);
3784        sys$synch(0, child_st);
3785        }
3786    return(1);
3787}
3788
3789static void sig_child(int chan)
3790{
3791#ifdef ARGPROC_DEBUG
3792    PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3793#endif
3794    if (child_st[0] == 0)
3795        child_st[0] = 1;
3796}
3797
3798static struct exit_control_block exit_block =
3799    {
3800    0,
3801    exit_handler,
3802    1,
3803    &exit_block.exit_status,
3804    0
3805    };
3806
3807static void pipe_and_fork(char **cmargv)
3808{
3809    char subcmd[2048];
3810    $DESCRIPTOR(cmddsc, "");
3811    static char mbxname[64];
3812    $DESCRIPTOR(mbxdsc, mbxname);
3813    int pid, j;
3814    unsigned long int zero = 0, one = 1;
3815
3816    strcpy(subcmd, cmargv[0]);
3817    for (j = 1; NULL != cmargv[j]; ++j)
3818        {
3819        strcat(subcmd, " \"");
3820        strcat(subcmd, cmargv[j]);
3821        strcat(subcmd, "\"");
3822        }
3823    cmddsc.dsc$a_pointer = subcmd;
3824    cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3825
3826        create_mbx(&child_chan,&mbxdsc);
3827#ifdef ARGPROC_DEBUG
3828    PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3829    PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3830#endif
3831    _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3832                               0, &pid, child_st, &zero, sig_child,
3833                               &child_chan));
3834#ifdef ARGPROC_DEBUG
3835    PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3836#endif
3837    sys$dclexh(&exit_block);
3838    if (NULL == freopen(mbxname, "wb", stdout))
3839        {
3840        PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3841        }
3842}
3843
3844static int background_process(int argc, char **argv)
3845{
3846char command[2048] = "$";
3847$DESCRIPTOR(value, "");
3848static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3849static $DESCRIPTOR(null, "NLA0:");
3850static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3851char pidstring[80];
3852$DESCRIPTOR(pidstr, "");
3853int pid;
3854unsigned long int flags = 17, one = 1, retsts;
3855
3856    strcat(command, argv[0]);
3857    while (--argc)
3858        {
3859        strcat(command, " \"");
3860        strcat(command, *(++argv));
3861        strcat(command, "\"");
3862        }
3863    value.dsc$a_pointer = command;
3864    value.dsc$w_length = strlen(value.dsc$a_pointer);
3865    _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3866    retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3867    if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3868        _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3869    }
3870    else {
3871        _ckvmssts_noperl(retsts);
3872    }
3873#ifdef ARGPROC_DEBUG
3874    PerlIO_printf(Perl_debug_log, "%s\n", command);
3875#endif
3876    sprintf(pidstring, "%08X", pid);
3877    PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3878    pidstr.dsc$a_pointer = pidstring;
3879    pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3880    lib$set_symbol(&pidsymbol, &pidstr);
3881    return(SS$_NORMAL);
3882}
3883/*}}}*/
3884/***** End of code taken from Mark Pizzolato's argproc.c package *****/
3885
3886
3887/* OS-specific initialization at image activation (not thread startup) */
3888/* Older VAXC header files lack these constants */
3889#ifndef JPI$_RIGHTS_SIZE
3890#  define JPI$_RIGHTS_SIZE 817
3891#endif
3892#ifndef KGB$M_SUBSYSTEM
3893#  define KGB$M_SUBSYSTEM 0x8
3894#endif
3895
3896/*{{{void vms_image_init(int *, char ***)*/
3897void
3898vms_image_init(int *argcp, char ***argvp)
3899{
3900  char eqv[LNM$C_NAMLENGTH+1] = "";
3901  unsigned int len, tabct = 8, tabidx = 0;
3902  unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3903  unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3904  unsigned short int dummy, rlen;
3905  struct dsc$descriptor_s **tabvec;
3906  dTHX;
3907  struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
3908                                 {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
3909                                 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3910                                 {          0,                0,    0,      0} };
3911
3912  _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3913  _ckvmssts(iosb[0]);
3914  for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3915    if (iprv[i]) {           /* Running image installed with privs? */
3916      _ckvmssts(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
3917      will_taint = TRUE;
3918      break;
3919    }
3920  }
3921  /* Rights identifiers might trigger tainting as well. */
3922  if (!will_taint && (rlen || rsz)) {
3923    while (rlen < rsz) {
3924      /* We didn't get all the identifiers on the first pass.  Allocate a
3925       * buffer much larger than $GETJPI wants (rsz is size in bytes that
3926       * were needed to hold all identifiers at time of last call; we'll
3927       * allocate that many unsigned long ints), and go back and get 'em.
3928       * If it gave us less than it wanted to despite ample buffer space,
3929       * something's broken.  Is your system missing a system identifier?
3930       */
3931      if (rsz <= jpilist[1].buflen) {
3932         /* Perl_croak accvios when used this early in startup. */
3933         fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3934                         rsz, (unsigned long) jpilist[1].buflen,
3935                         "Check your rights database for corruption.\n");
3936         exit(SS$_ABORT);
3937      }
3938      if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3939      jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3940      jpilist[1].buflen = rsz * sizeof(unsigned long int);
3941      _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3942      _ckvmssts(iosb[0]);
3943    }
3944    mask = jpilist[1].bufadr;
3945    /* Check attribute flags for each identifier (2nd longword); protected
3946     * subsystem identifiers trigger tainting.
3947     */
3948    for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3949      if (mask[i] & KGB$M_SUBSYSTEM) {
3950        will_taint = TRUE;
3951        break;
3952      }
3953    }
3954    if (mask != rlst) Safefree(mask);
3955  }
3956  /* We need to use this hack to tell Perl it should run with tainting,
3957   * since its tainting flag may be part of the PL_curinterp struct, which
3958   * hasn't been allocated when vms_image_init() is called.
3959   */
3960  if (will_taint) {
3961    char ***newap;
3962    New(1320,newap,*argcp+2,char **);
3963    newap[0] = argvp[0];
3964    *newap[1] = "-T";
3965    Copy(argvp[1],newap[2],*argcp-1,char **);
3966    /* We orphan the old argv, since we don't know where it's come from,
3967     * so we don't know how to free it.
3968     */
3969    *argcp++; argvp = newap;
3970  }
3971  else {  /* Did user explicitly request tainting? */
3972    int i;
3973    char *cp, **av = *argvp;
3974    for (i = 1; i < *argcp; i++) {
3975      if (*av[i] != '-') break;
3976      for (cp = av[i]+1; *cp; cp++) {
3977        if (*cp == 'T') { will_taint = 1; break; }
3978        else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3979                  strchr("DFIiMmx",*cp)) break;
3980      }
3981      if (will_taint) break;
3982    }
3983  }
3984
3985  for (tabidx = 0;
3986       len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3987       tabidx++) {
3988    if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3989    else if (tabidx >= tabct) {
3990      tabct += 8;
3991      Renew(tabvec,tabct,struct dsc$descriptor_s *);
3992    }
3993    New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3994    tabvec[tabidx]->dsc$w_length  = 0;
3995    tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
3996    tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
3997    tabvec[tabidx]->dsc$a_pointer = NULL;
3998    _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3999  }
4000  if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4001
4002  getredirection(argcp,argvp);
4003#if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4004  {
4005# include <reentrancy.h>
4006  (void) decc$set_reentrancy(C$C_MULTITHREAD);
4007  }
4008#endif
4009  return;
4010}
4011/*}}}*/
4012
4013
4014/* trim_unixpath()
4015 * Trim Unix-style prefix off filespec, so it looks like what a shell
4016 * glob expansion would return (i.e. from specified prefix on, not
4017 * full path).  Note that returned filespec is Unix-style, regardless
4018 * of whether input filespec was VMS-style or Unix-style.
4019 *
4020 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4021 * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4022 * vector of options; at present, only bit 0 is used, and if set tells
4023 * trim unixpath to try the current default directory as a prefix when
4024 * presented with a possibly ambiguous ... wildcard.
4025 *
4026 * Returns !=0 on success, with trimmed filespec replacing contents of
4027 * fspec, and 0 on failure, with contents of fpsec unchanged.
4028 */
4029/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4030int
4031Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4032{
4033  char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4034       *template, *base, *end, *cp1, *cp2;
4035  register int tmplen, reslen = 0, dirs = 0;
4036
4037  if (!wildspec || !fspec) return 0;
4038  if (strpbrk(wildspec,"]>:") != NULL) {
4039    if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4040    else template = unixwild;
4041  }
4042  else template = wildspec;
4043  if (strpbrk(fspec,"]>:") != NULL) {
4044    if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4045    else base = unixified;
4046    /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4047     * check to see that final result fits into (isn't longer than) fspec */
4048    reslen = strlen(fspec);
4049  }
4050  else base = fspec;
4051
4052  /* No prefix or absolute path on wildcard, so nothing to remove */
4053  if (!*template || *template == '/') {
4054    if (base == fspec) return 1;
4055    tmplen = strlen(unixified);
4056    if (tmplen > reslen) return 0;  /* not enough space */
4057    /* Copy unixified resultant, including trailing NUL */
4058    memmove(fspec,unixified,tmplen+1);
4059    return 1;
4060  }
4061
4062  for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4063  if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4064    for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4065    for (cp1 = end ;cp1 >= base; cp1--)
4066      if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4067        { cp1++; break; }
4068    if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4069    return 1;
4070  }
4071  else {
4072    char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4073    char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4074    int ells = 1, totells, segdirs, match;
4075    struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4076                            resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4077
4078    while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4079    totells = ells;
4080    for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4081    if (ellipsis == template && opts & 1) {
4082      /* Template begins with an ellipsis.  Since we can't tell how many
4083       * directory names at the front of the resultant to keep for an
4084       * arbitrary starting point, we arbitrarily choose the current
4085       * default directory as a starting point.  If it's there as a prefix,
4086       * clip it off.  If not, fall through and act as if the leading
4087       * ellipsis weren't there (i.e. return shortest possible path that
4088       * could match template).
4089       */
4090      if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4091      for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4092        if (_tolower(*cp1) != _tolower(*cp2)) break;
4093      segdirs = dirs - totells;  /* Min # of dirs we must have left */
4094      for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4095      if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4096        memcpy(fspec,cp2+1,end - cp2);
4097        return 1;
4098      }
4099    }
4100    /* First off, back up over constant elements at end of path */
4101    if (dirs) {
4102      for (front = end ; front >= base; front--)
4103         if (*front == '/' && !dirs--) { front++; break; }
4104    }
4105    for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4106         cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4107    if (cp1 != '\0') return 0;  /* Path too long. */
4108    lcend = cp2;
4109    *cp2 = '\0';  /* Pick up with memcpy later */
4110    lcfront = lcres + (front - base);
4111    /* Now skip over each ellipsis and try to match the path in front of it. */
4112    while (ells--) {
4113      for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4114        if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4115            *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4116      if (cp1 < template) break; /* template started with an ellipsis */
4117      if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4118        ellipsis = cp1; continue;
4119      }
4120      wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4121      nextell = cp1;
4122      for (segdirs = 0, cp2 = tpl;
4123           cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4124           cp1++, cp2++) {
4125         if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4126         else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4127         if (*cp2 == '/') segdirs++;
4128      }
4129      if (cp1 != ellipsis - 1) return 0; /* Path too long */
4130      /* Back up at least as many dirs as in template before matching */
4131      for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4132        if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4133      for (match = 0; cp1 > lcres;) {
4134        resdsc.dsc$a_pointer = cp1;
4135        if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4136          match++;
4137          if (match == 1) lcfront = cp1;
4138        }
4139        for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4140      }
4141      if (!match) return 0;  /* Can't find prefix ??? */
4142      if (match > 1 && opts & 1) {
4143        /* This ... wildcard could cover more than one set of dirs (i.e.
4144         * a set of similar dir names is repeated).  If the template
4145         * contains more than 1 ..., upstream elements could resolve the
4146         * ambiguity, but it's not worth a full backtracking setup here.
4147         * As a quick heuristic, clip off the current default directory
4148         * if it's present to find the trimmed spec, else use the
4149         * shortest string that this ... could cover.
4150         */
4151        char def[NAM$C_MAXRSS+1], *st;
4152
4153        if (getcwd(def, sizeof def,0) == NULL) return 0;
4154        for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4155          if (_tolower(*cp1) != _tolower(*cp2)) break;
4156        segdirs = dirs - totells;  /* Min # of dirs we must have left */
4157        for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4158        if (*cp1 == '\0' && *cp2 == '/') {
4159          memcpy(fspec,cp2+1,end - cp2);
4160          return 1;
4161        }
4162        /* Nope -- stick with lcfront from above and keep going. */
4163      }
4164    }
4165    memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4166    return 1;
4167    ellipsis = nextell;
4168  }
4169
4170}  /* end of trim_unixpath() */
4171/*}}}*/
4172
4173
4174/*
4175 *  VMS readdir() routines.
4176 *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4177 *
4178 *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4179 *  Minor modifications to original routines.
4180 */
4181
4182    /* Number of elements in vms_versions array */
4183#define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4184
4185/*
4186 *  Open a directory, return a handle for later use.
4187 */
4188/*{{{ DIR *opendir(char*name) */
4189DIR *
4190Perl_opendir(pTHX_ char *name)
4191{
4192    DIR *dd;
4193    char dir[NAM$C_MAXRSS+1];
4194    Stat_t sb;
4195
4196    if (do_tovmspath(name,dir,0) == NULL) {
4197      return NULL;
4198    }
4199    if (flex_stat(dir,&sb) == -1) return NULL;
4200    if (!S_ISDIR(sb.st_mode)) {
4201      set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4202      return NULL;
4203    }
4204    if (!cando_by_name(S_IRUSR,0,dir)) {
4205      set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4206      return NULL;
4207    }
4208    /* Get memory for the handle, and the pattern. */
4209    New(1306,dd,1,DIR);
4210    New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4211
4212    /* Fill in the fields; mainly playing with the descriptor. */
4213    (void)sprintf(dd->pattern, "%s*.*",dir);
4214    dd->context = 0;
4215    dd->count = 0;
4216    dd->vms_wantversions = 0;
4217    dd->pat.dsc$a_pointer = dd->pattern;
4218    dd->pat.dsc$w_length = strlen(dd->pattern);
4219    dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4220    dd->pat.dsc$b_class = DSC$K_CLASS_S;
4221
4222    return dd;
4223}  /* end of opendir() */
4224/*}}}*/
4225
4226/*
4227 *  Set the flag to indicate we want versions or not.
4228 */
4229/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4230void
4231vmsreaddirversions(DIR *dd, int flag)
4232{
4233    dd->vms_wantversions = flag;
4234}
4235/*}}}*/
4236
4237/*
4238 *  Free up an opened directory.
4239 */
4240/*{{{ void closedir(DIR *dd)*/
4241void
4242closedir(DIR *dd)
4243{
4244    (void)lib$find_file_end(&dd->context);
4245    Safefree(dd->pattern);
4246    Safefree((char *)dd);
4247}
4248/*}}}*/
4249
4250/*
4251 *  Collect all the version numbers for the current file.
4252 */
4253static void
4254collectversions(dd)
4255    DIR *dd;
4256{
4257    struct dsc$descriptor_s     pat;
4258    struct dsc$descriptor_s     res;
4259    struct dirent *e;
4260    char *p, *text, buff[sizeof dd->entry.d_name];
4261    int i;
4262    unsigned long context, tmpsts;
4263    dTHX;
4264
4265    /* Convenient shorthand. */
4266    e = &dd->entry;
4267
4268    /* Add the version wildcard, ignoring the "*.*" put on before */
4269    i = strlen(dd->pattern);
4270    New(1308,text,i + e->d_namlen + 3,char);
4271    (void)strcpy(text, dd->pattern);
4272    (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4273
4274    /* Set up the pattern descriptor. */
4275    pat.dsc$a_pointer = text;
4276    pat.dsc$w_length = i + e->d_namlen - 1;
4277    pat.dsc$b_dtype = DSC$K_DTYPE_T;
4278    pat.dsc$b_class = DSC$K_CLASS_S;
4279
4280    /* Set up result descriptor. */
4281    res.dsc$a_pointer = buff;
4282    res.dsc$w_length = sizeof buff - 2;
4283    res.dsc$b_dtype = DSC$K_DTYPE_T;
4284    res.dsc$b_class = DSC$K_CLASS_S;
4285
4286    /* Read files, collecting versions. */
4287    for (context = 0, e->vms_verscount = 0;
4288         e->vms_verscount < VERSIZE(e);
4289         e->vms_verscount++) {
4290        tmpsts = lib$find_file(&pat, &res, &context);
4291        if (tmpsts == RMS$_NMF || context == 0) break;
4292        _ckvmssts(tmpsts);
4293        buff[sizeof buff - 1] = '\0';
4294        if ((p = strchr(buff, ';')))
4295            e->vms_versions[e->vms_verscount] = atoi(p + 1);
4296        else
4297            e->vms_versions[e->vms_verscount] = -1;
4298    }
4299
4300    _ckvmssts(lib$find_file_end(&context));
4301    Safefree(text);
4302
4303}  /* end of collectversions() */
4304
4305/*
4306 *  Read the next entry from the directory.
4307 */
4308/*{{{ struct dirent *readdir(DIR *dd)*/
4309struct dirent *
4310readdir(DIR *dd)
4311{
4312    struct dsc$descriptor_s     res;
4313    char *p, buff[sizeof dd->entry.d_name];
4314    unsigned long int tmpsts;
4315
4316    /* Set up result descriptor, and get next file. */
4317    res.dsc$a_pointer = buff;
4318    res.dsc$w_length = sizeof buff - 2;
4319    res.dsc$b_dtype = DSC$K_DTYPE_T;
4320    res.dsc$b_class = DSC$K_CLASS_S;
4321    tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4322    if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4323    if (!(tmpsts & 1)) {
4324      set_vaxc_errno(tmpsts);
4325      switch (tmpsts) {
4326        case RMS$_PRV:
4327          set_errno(EACCES); break;
4328        case RMS$_DEV:
4329          set_errno(ENODEV); break;
4330        case RMS$_DIR:
4331          set_errno(ENOTDIR); break;
4332        case RMS$_FNF: case RMS$_DNF:
4333          set_errno(ENOENT); break;
4334        default:
4335          set_errno(EVMSERR);
4336      }
4337      return NULL;
4338    }
4339    dd->count++;
4340    /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4341    buff[sizeof buff - 1] = '\0';
4342    for (p = buff; *p; p++) *p = _tolower(*p);
4343    while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4344    *p = '\0';
4345
4346    /* Skip any directory component and just copy the name. */
4347    if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4348    else (void)strcpy(dd->entry.d_name, buff);
4349
4350    /* Clobber the version. */
4351    if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4352
4353    dd->entry.d_namlen = strlen(dd->entry.d_name);
4354    dd->entry.vms_verscount = 0;
4355    if (dd->vms_wantversions) collectversions(dd);
4356    return &dd->entry;
4357
4358}  /* end of readdir() */
4359/*}}}*/
4360
4361/*
4362 *  Return something that can be used in a seekdir later.
4363 */
4364/*{{{ long telldir(DIR *dd)*/
4365long
4366telldir(DIR *dd)
4367{
4368    return dd->count;
4369}
4370/*}}}*/
4371
4372/*
4373 *  Return to a spot where we used to be.  Brute force.
4374 */
4375/*{{{ void seekdir(DIR *dd,long count)*/
4376void
4377seekdir(DIR *dd, long count)
4378{
4379    int vms_wantversions;
4380    dTHX;
4381
4382    /* If we haven't done anything yet... */
4383    if (dd->count == 0)
4384        return;
4385
4386    /* Remember some state, and clear it. */
4387    vms_wantversions = dd->vms_wantversions;
4388    dd->vms_wantversions = 0;
4389    _ckvmssts(lib$find_file_end(&dd->context));
4390    dd->context = 0;
4391
4392    /* The increment is in readdir(). */
4393    for (dd->count = 0; dd->count < count; )
4394        (void)readdir(dd);
4395
4396    dd->vms_wantversions = vms_wantversions;
4397
4398}  /* end of seekdir() */
4399/*}}}*/
4400
4401/* VMS subprocess management
4402 *
4403 * my_vfork() - just a vfork(), after setting a flag to record that
4404 * the current script is trying a Unix-style fork/exec.
4405 *
4406 * vms_do_aexec() and vms_do_exec() are called in response to the
4407 * perl 'exec' function.  If this follows a vfork call, then they
4408 * call out the the regular perl routines in doio.c which do an
4409 * execvp (for those who really want to try this under VMS).
4410 * Otherwise, they do exactly what the perl docs say exec should
4411 * do - terminate the current script and invoke a new command
4412 * (See below for notes on command syntax.)
4413 *
4414 * do_aspawn() and do_spawn() implement the VMS side of the perl
4415 * 'system' function.
4416 *
4417 * Note on command arguments to perl 'exec' and 'system': When handled
4418 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4419 * are concatenated to form a DCL command string.  If the first arg
4420 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4421 * the the command string is handed off to DCL directly.  Otherwise,
4422 * the first token of the command is taken as the filespec of an image
4423 * to run.  The filespec is expanded using a default type of '.EXE' and
4424 * the process defaults for device, directory, etc., and if found, the resultant
4425 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4426 * the command string as parameters.  This is perhaps a bit complicated,
4427 * but I hope it will form a happy medium between what VMS folks expect
4428 * from lib$spawn and what Unix folks expect from exec.
4429 */
4430
4431static int vfork_called;
4432
4433/*{{{int my_vfork()*/
4434int
4435my_vfork()
4436{
4437  vfork_called++;
4438  return vfork();
4439}
4440/*}}}*/
4441
4442
4443static void
4444vms_execfree(pTHX) {
4445  if (PL_Cmd) {
4446    if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4447    PL_Cmd = Nullch;
4448  }
4449  if (VMScmd.dsc$a_pointer) {
4450    Safefree(VMScmd.dsc$a_pointer);
4451    VMScmd.dsc$w_length = 0;
4452    VMScmd.dsc$a_pointer = Nullch;
4453  }
4454}
4455
4456static char *
4457setup_argstr(SV *really, SV **mark, SV **sp)
4458{
4459  dTHX;
4460  char *junk, *tmps = Nullch;
4461  register size_t cmdlen = 0;
4462  size_t rlen;
4463  register SV **idx;
4464  STRLEN n_a;
4465
4466  idx = mark;
4467  if (really) {
4468    tmps = SvPV(really,rlen);
4469    if (*tmps) {
4470      cmdlen += rlen + 1;
4471      idx++;
4472    }
4473  }
4474 
4475  for (idx++; idx <= sp; idx++) {
4476    if (*idx) {
4477      junk = SvPVx(*idx,rlen);
4478      cmdlen += rlen ? rlen + 1 : 0;
4479    }
4480  }
4481  New(401,PL_Cmd,cmdlen+1,char);
4482
4483  if (tmps && *tmps) {
4484    strcpy(PL_Cmd,tmps);
4485    mark++;
4486  }
4487  else *PL_Cmd = '\0';
4488  while (++mark <= sp) {
4489    if (*mark) {
4490      char *s = SvPVx(*mark,n_a);
4491      if (!*s) continue;
4492      if (*PL_Cmd) strcat(PL_Cmd," ");
4493      strcat(PL_Cmd,s);
4494    }
4495  }
4496  return PL_Cmd;
4497
4498}  /* end of setup_argstr() */
4499
4500
4501static unsigned long int
4502setup_cmddsc(char *cmd, int check_img)
4503{
4504  char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4505  $DESCRIPTOR(defdsc,".EXE");
4506  $DESCRIPTOR(defdsc2,".");
4507  $DESCRIPTOR(resdsc,resspec);
4508  struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4509  unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4510  register char *s, *rest, *cp, *wordbreak;
4511  register int isdcl;
4512  dTHX;
4513
4514  if (strlen(cmd) >
4515      (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4516    return LIB$_INVARG;
4517  s = cmd;
4518  while (*s && isspace(*s)) s++;
4519
4520  if (*s == '@' || *s == '$') {
4521    vmsspec[0] = *s;  rest = s + 1;
4522    for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4523  }
4524  else { cp = vmsspec; rest = s; }
4525  if (*rest == '.' || *rest == '/') {
4526    char *cp2;
4527    for (cp2 = resspec;
4528         *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4529         rest++, cp2++) *cp2 = *rest;
4530    *cp2 = '\0';
4531    if (do_tovmsspec(resspec,cp,0)) {
4532      s = vmsspec;
4533      if (*rest) {
4534        for (cp2 = vmsspec + strlen(vmsspec);
4535             *rest && cp2 - vmsspec < sizeof vmsspec;
4536             rest++, cp2++) *cp2 = *rest;
4537        *cp2 = '\0';
4538      }
4539    }
4540  }
4541  /* Intuit whether verb (first word of cmd) is a DCL command:
4542   *   - if first nonspace char is '@', it's a DCL indirection
4543   * otherwise
4544   *   - if verb contains a filespec separator, it's not a DCL command
4545   *   - if it doesn't, caller tells us whether to default to a DCL
4546   *     command, or to a local image unless told it's DCL (by leading '$')
4547   */
4548  if (*s == '@') isdcl = 1;
4549  else {
4550    register char *filespec = strpbrk(s,":<[.;");
4551    rest = wordbreak = strpbrk(s," \"\t/");
4552    if (!wordbreak) wordbreak = s + strlen(s);
4553    if (*s == '$') check_img = 0;
4554    if (filespec && (filespec < wordbreak)) isdcl = 0;
4555    else isdcl = !check_img;
4556  }
4557
4558  if (!isdcl) {
4559    imgdsc.dsc$a_pointer = s;
4560    imgdsc.dsc$w_length = wordbreak - s;
4561    retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4562    if (!(retsts&1)) {
4563        _ckvmssts(lib$find_file_end(&cxt));
4564        retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4565    if (!(retsts & 1) && *s == '$') {
4566          _ckvmssts(lib$find_file_end(&cxt));
4567      imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4568      retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4569          if (!(retsts&1)) {
4570      _ckvmssts(lib$find_file_end(&cxt));
4571            retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4572          }
4573    }
4574    }
4575    _ckvmssts(lib$find_file_end(&cxt));
4576
4577    if (retsts & 1) {
4578      FILE *fp;
4579      s = resspec;
4580      while (*s && !isspace(*s)) s++;
4581      *s = '\0';
4582
4583      /* check that it's really not DCL with no file extension */
4584      fp = fopen(resspec,"r","ctx=bin,shr=get");
4585      if (fp) {
4586        char b[4] = {0,0,0,0};
4587        read(fileno(fp),b,4);
4588        isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4589        fclose(fp);
4590      }
4591      if (check_img && isdcl) return RMS$_FNF;
4592
4593      if (cando_by_name(S_IXUSR,0,resspec)) {
4594        New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4595        if (!isdcl) {
4596        strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4597        } else {
4598            strcpy(VMScmd.dsc$a_pointer,"@");
4599        }
4600        strcat(VMScmd.dsc$a_pointer,resspec);
4601        if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4602        VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4603        return retsts;
4604      }
4605      else retsts = RMS$_PRV;
4606    }
4607  }
4608  /* It's either a DCL command or we couldn't find a suitable image */
4609  VMScmd.dsc$w_length = strlen(cmd);
4610  if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4611  else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4612  if (!(retsts & 1)) {
4613    /* just hand off status values likely to be due to user error */
4614    if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4615        retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4616       (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4617    else { _ckvmssts(retsts); }
4618  }
4619
4620  return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4621
4622}  /* end of setup_cmddsc() */
4623
4624
4625/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4626bool
4627vms_do_aexec(SV *really,SV **mark,SV **sp)
4628{
4629  dTHX;
4630  if (sp > mark) {
4631    if (vfork_called) {           /* this follows a vfork - act Unixish */
4632      vfork_called--;
4633      if (vfork_called < 0) {
4634        Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4635        vfork_called = 0;
4636      }
4637      else return do_aexec(really,mark,sp);
4638    }
4639                                           /* no vfork - act VMSish */
4640    return vms_do_exec(setup_argstr(really,mark,sp));
4641
4642  }
4643
4644  return FALSE;
4645}  /* end of vms_do_aexec() */
4646/*}}}*/
4647
4648/* {{{bool vms_do_exec(char *cmd) */
4649bool
4650vms_do_exec(char *cmd)
4651{
4652
4653  dTHX;
4654  if (vfork_called) {             /* this follows a vfork - act Unixish */
4655    vfork_called--;
4656    if (vfork_called < 0) {
4657      Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4658      vfork_called = 0;
4659    }
4660    else return do_exec(cmd);
4661  }
4662
4663  {                               /* no vfork - act VMSish */
4664    unsigned long int retsts;
4665
4666    TAINT_ENV();
4667    TAINT_PROPER("exec");
4668    if ((retsts = setup_cmddsc(cmd,1)) & 1)
4669      retsts = lib$do_command(&VMScmd);
4670
4671    switch (retsts) {
4672      case RMS$_FNF: case RMS$_DNF:
4673        set_errno(ENOENT); break;
4674      case RMS$_DIR:
4675        set_errno(ENOTDIR); break;
4676      case RMS$_DEV:
4677        set_errno(ENODEV); break;
4678      case RMS$_PRV:
4679        set_errno(EACCES); break;
4680      case RMS$_SYN:
4681        set_errno(EINVAL); break;
4682      case CLI$_BUFOVF:
4683        set_errno(E2BIG); break;
4684      case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4685        _ckvmssts(retsts); /* fall through */
4686      default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4687        set_errno(EVMSERR);
4688    }
4689    set_vaxc_errno(retsts);
4690    if (ckWARN(WARN_EXEC)) {
4691      Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4692             VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4693    }
4694    vms_execfree(aTHX);
4695  }
4696
4697  return FALSE;
4698
4699}  /* end of vms_do_exec() */
4700/*}}}*/
4701
4702unsigned long int do_spawn(char *);
4703
4704/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4705unsigned long int
4706do_aspawn(void *really,void **mark,void **sp)
4707{
4708  dTHX;
4709  if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4710
4711  return SS$_ABORT;
4712}  /* end of do_aspawn() */
4713/*}}}*/
4714
4715/* {{{unsigned long int do_spawn(char *cmd) */
4716unsigned long int
4717do_spawn(char *cmd)
4718{
4719  unsigned long int sts, substs, hadcmd = 1;
4720  dTHX;
4721
4722  TAINT_ENV();
4723  TAINT_PROPER("spawn");
4724  if (!cmd || !*cmd) {
4725    hadcmd = 0;
4726    sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4727  }
4728  else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4729    sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4730  }
4731 
4732  if (!(sts & 1)) {
4733    switch (sts) {
4734      case RMS$_FNF:  case RMS$_DNF:
4735        set_errno(ENOENT); break;
4736      case RMS$_DIR:
4737        set_errno(ENOTDIR); break;
4738      case RMS$_DEV:
4739        set_errno(ENODEV); break;
4740      case RMS$_PRV:
4741        set_errno(EACCES); break;
4742      case RMS$_SYN:
4743        set_errno(EINVAL); break;
4744      case CLI$_BUFOVF:
4745        set_errno(E2BIG); break;
4746      case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4747        _ckvmssts(sts); /* fall through */
4748      default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4749        set_errno(EVMSERR);
4750    }
4751    set_vaxc_errno(sts);
4752    if (ckWARN(WARN_EXEC)) {
4753      Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4754             hadcmd ? VMScmd.dsc$w_length :  0,
4755             hadcmd ? VMScmd.dsc$a_pointer : "",
4756             Strerror(errno));
4757    }
4758  }
4759  vms_execfree(aTHX);
4760  return substs;
4761
4762}  /* end of do_spawn() */
4763/*}}}*/
4764
4765
4766static unsigned int *sockflags, sockflagsize;
4767
4768/*
4769 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4770 * routines found in some versions of the CRTL can't deal with sockets.
4771 * We don't shim the other file open routines since a socket isn't
4772 * likely to be opened by a name.
4773 */
4774/*{{{ FILE *my_fdopen(int fd, char *mode)*/
4775FILE *my_fdopen(int fd, char *mode)
4776{
4777  FILE *fp = fdopen(fd,mode);
4778
4779  if (fp) {
4780    unsigned int fdoff = fd / sizeof(unsigned int);
4781    struct stat sbuf; /* native stat; we don't need flex_stat */
4782    if (!sockflagsize || fdoff > sockflagsize) {
4783      if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
4784      else           New  (1324,sockflags,fdoff+2,unsigned int);
4785      memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4786      sockflagsize = fdoff + 2;
4787    }
4788    if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4789      sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4790  }
4791  return fp;
4792
4793}
4794/*}}}*/
4795
4796
4797/*
4798 * Clear the corresponding bit when the (possibly) socket stream is closed.
4799 * There still a small hole: we miss an implicit close which might occur
4800 * via freopen().  >> Todo
4801 */
4802/*{{{ int my_fclose(FILE *fp)*/
4803int my_fclose(FILE *fp) {
4804  if (fp) {
4805    unsigned int fd = fileno(fp);
4806    unsigned int fdoff = fd / sizeof(unsigned int);
4807
4808    if (sockflagsize && fdoff <= sockflagsize)
4809      sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4810  }
4811  return fclose(fp);
4812}
4813/*}}}*/
4814
4815
4816/*
4817 * A simple fwrite replacement which outputs itmsz*nitm chars without
4818 * introducing record boundaries every itmsz chars.
4819 * We are using fputs, which depends on a terminating null.  We may
4820 * well be writing binary data, so we need to accommodate not only
4821 * data with nulls sprinkled in the middle but also data with no null
4822 * byte at the end.
4823 */
4824/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4825int
4826my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4827{
4828  register char *cp, *end, *cpd, *data;
4829  register unsigned int fd = fileno(dest);
4830  register unsigned int fdoff = fd / sizeof(unsigned int);
4831  int retval;
4832  int bufsize = itmsz * nitm + 1;
4833
4834  if (fdoff < sockflagsize &&
4835      (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4836    if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4837    return nitm;
4838  }
4839
4840  _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4841  memcpy( data, src, itmsz*nitm );
4842  data[itmsz*nitm] = '\0';
4843
4844  end = data + itmsz * nitm;
4845  retval = (int) nitm; /* on success return # items written */
4846
4847  cpd = data;
4848  while (cpd <= end) {
4849    for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4850    if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4851    if (cp < end)
4852      if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4853    cpd = cp + 1;
4854  }
4855
4856  if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4857  return retval;
4858
4859}  /* end of my_fwrite() */
4860/*}}}*/
4861
4862/*{{{ int my_flush(FILE *fp)*/
4863int
4864my_flush(FILE *fp)
4865{
4866    int res;
4867    if ((res = fflush(fp)) == 0 && fp) {
4868#ifdef VMS_DO_SOCKETS
4869        Stat_t s;
4870        if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4871#endif
4872            res = fsync(fileno(fp));
4873    }
4874/*
4875 * If the flush succeeded but set end-of-file, we need to clear
4876 * the error because our caller may check ferror().  BTW, this
4877 * probably means we just flushed an empty file.
4878 */
4879    if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4880
4881    return res;
4882}
4883/*}}}*/
4884
4885/*
4886 * Here are replacements for the following Unix routines in the VMS environment:
4887 *      getpwuid    Get information for a particular UIC or UID
4888 *      getpwnam    Get information for a named user
4889 *      getpwent    Get information for each user in the rights database
4890 *      setpwent    Reset search to the start of the rights database
4891 *      endpwent    Finish searching for users in the rights database
4892 *
4893 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4894 * (defined in pwd.h), which contains the following fields:-
4895 *      struct passwd {
4896 *              char        *pw_name;    Username (in lower case)
4897 *              char        *pw_passwd;  Hashed password
4898 *              unsigned int pw_uid;     UIC
4899 *              unsigned int pw_gid;     UIC group  number
4900 *              char        *pw_unixdir; Default device/directory (VMS-style)
4901 *              char        *pw_gecos;   Owner name
4902 *              char        *pw_dir;     Default device/directory (Unix-style)
4903 *              char        *pw_shell;   Default CLI name (eg. DCL)
4904 *      };
4905 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4906 *
4907 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4908 * not the UIC member number (eg. what's returned by getuid()),
4909 * getpwuid() can accept either as input (if uid is specified, the caller's
4910 * UIC group is used), though it won't recognise gid=0.
4911 *
4912 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4913 * information about other users in your group or in other groups, respectively.
4914 * If the required privilege is not available, then these routines fill only
4915 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4916 * string).
4917 *
4918 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4919 */
4920
4921/* sizes of various UAF record fields */
4922#define UAI$S_USERNAME 12
4923#define UAI$S_IDENT    31
4924#define UAI$S_OWNER    31
4925#define UAI$S_DEFDEV   31
4926#define UAI$S_DEFDIR   63
4927#define UAI$S_DEFCLI   31
4928#define UAI$S_PWD       8
4929
4930#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
4931                        (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4932                        (uic).uic$v_group  != UIC$K_WILD_GROUP)
4933
4934static char __empty[]= "";
4935static struct passwd __passwd_empty=
4936    {(char *) __empty, (char *) __empty, 0, 0,
4937     (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4938static int contxt= 0;
4939static struct passwd __pwdcache;
4940static char __pw_namecache[UAI$S_IDENT+1];
4941
4942/*
4943 * This routine does most of the work extracting the user information.
4944 */
4945static int fillpasswd (const char *name, struct passwd *pwd)
4946{
4947    dTHX;
4948    static struct {
4949        unsigned char length;
4950        char pw_gecos[UAI$S_OWNER+1];
4951    } owner;
4952    static union uicdef uic;
4953    static struct {
4954        unsigned char length;
4955        char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4956    } defdev;
4957    static struct {
4958        unsigned char length;
4959        char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4960    } defdir;
4961    static struct {
4962        unsigned char length;
4963        char pw_shell[UAI$S_DEFCLI+1];
4964    } defcli;
4965    static char pw_passwd[UAI$S_PWD+1];
4966
4967    static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4968    struct dsc$descriptor_s name_desc;
4969    unsigned long int sts;
4970
4971    static struct itmlst_3 itmlst[]= {
4972        {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
4973        {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
4974        {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
4975        {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
4976        {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
4977        {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
4978        {0,                0,           NULL,    NULL}};
4979
4980    name_desc.dsc$w_length=  strlen(name);
4981    name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
4982    name_desc.dsc$b_class=   DSC$K_CLASS_S;
4983    name_desc.dsc$a_pointer= (char *) name;
4984
4985/*  Note that sys$getuai returns many fields as counted strings. */
4986    sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4987    if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4988      set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4989    }
4990    else { _ckvmssts(sts); }
4991    if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
4992
4993    if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
4994    if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4995    if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4996    if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4997    memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4998    owner.pw_gecos[lowner]=            '\0';
4999    defdev.pw_dir[ldefdev+ldefdir]= '\0';
5000    defcli.pw_shell[ldefcli]=          '\0';
5001    if (valid_uic(uic)) {
5002        pwd->pw_uid= uic.uic$l_uic;
5003        pwd->pw_gid= uic.uic$v_group;
5004    }
5005    else
5006      Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5007    pwd->pw_passwd=  pw_passwd;
5008    pwd->pw_gecos=   owner.pw_gecos;
5009    pwd->pw_dir=     defdev.pw_dir;
5010    pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5011    pwd->pw_shell=   defcli.pw_shell;
5012    if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5013        int ldir;
5014        ldir= strlen(pwd->pw_unixdir) - 1;
5015        if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5016    }
5017    else
5018        strcpy(pwd->pw_unixdir, pwd->pw_dir);
5019    __mystrtolower(pwd->pw_unixdir);
5020    return 1;
5021}
5022
5023/*
5024 * Get information for a named user.
5025*/
5026/*{{{struct passwd *getpwnam(char *name)*/
5027struct passwd *my_getpwnam(char *name)
5028{
5029    struct dsc$descriptor_s name_desc;
5030    union uicdef uic;
5031    unsigned long int status, sts;
5032    dTHX;
5033                                 
5034    __pwdcache = __passwd_empty;
5035    if (!fillpasswd(name, &__pwdcache)) {
5036      /* We still may be able to determine pw_uid and pw_gid */
5037      name_desc.dsc$w_length=  strlen(name);
5038      name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5039      name_desc.dsc$b_class=   DSC$K_CLASS_S;
5040      name_desc.dsc$a_pointer= (char *) name;
5041      if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5042        __pwdcache.pw_uid= uic.uic$l_uic;
5043        __pwdcache.pw_gid= uic.uic$v_group;
5044      }
5045      else {
5046        if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5047          set_vaxc_errno(sts);
5048          set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5049          return NULL;
5050        }
5051        else { _ckvmssts(sts); }
5052      }
5053    }
5054    strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5055    __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5056    __pwdcache.pw_name= __pw_namecache;
5057    return &__pwdcache;
5058}  /* end of my_getpwnam() */
5059/*}}}*/
5060
5061/*
5062 * Get information for a particular UIC or UID.
5063 * Called by my_getpwent with uid=-1 to list all users.
5064*/
5065/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5066struct passwd *my_getpwuid(Uid_t uid)
5067{
5068    const $DESCRIPTOR(name_desc,__pw_namecache);
5069    unsigned short lname;
5070    union uicdef uic;
5071    unsigned long int status;
5072    dTHX;
5073
5074    if (uid == (unsigned int) -1) {
5075      do {
5076        status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5077        if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5078          set_vaxc_errno(status);
5079          set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5080          my_endpwent();
5081          return NULL;
5082        }
5083        else { _ckvmssts(status); }
5084      } while (!valid_uic (uic));
5085    }
5086    else {
5087      uic.uic$l_uic= uid;
5088      if (!uic.uic$v_group)
5089        uic.uic$v_group= PerlProc_getgid();
5090      if (valid_uic(uic))
5091        status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5092      else status = SS$_IVIDENT;
5093      if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5094          status == RMS$_PRV) {
5095        set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5096        return NULL;
5097      }
5098      else { _ckvmssts(status); }
5099    }
5100    __pw_namecache[lname]= '\0';
5101    __mystrtolower(__pw_namecache);
5102
5103    __pwdcache = __passwd_empty;
5104    __pwdcache.pw_name = __pw_namecache;
5105
5106/*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5107    The identifier's value is usually the UIC, but it doesn't have to be,
5108    so if we can, we let fillpasswd update this. */
5109    __pwdcache.pw_uid =  uic.uic$l_uic;
5110    __pwdcache.pw_gid =  uic.uic$v_group;
5111
5112    fillpasswd(__pw_namecache, &__pwdcache);
5113    return &__pwdcache;
5114
5115}  /* end of my_getpwuid() */
5116/*}}}*/
5117
5118/*
5119 * Get information for next user.
5120*/
5121/*{{{struct passwd *my_getpwent()*/
5122struct passwd *my_getpwent()
5123{
5124    return (my_getpwuid((unsigned int) -1));
5125}
5126/*}}}*/
5127
5128/*
5129 * Finish searching rights database for users.
5130*/
5131/*{{{void my_endpwent()*/
5132void my_endpwent()
5133{
5134    dTHX;
5135    if (contxt) {
5136      _ckvmssts(sys$finish_rdb(&contxt));
5137      contxt= 0;
5138    }
5139}
5140/*}}}*/
5141
5142#ifdef HOMEGROWN_POSIX_SIGNALS
5143  /* Signal handling routines, pulled into the core from POSIX.xs.
5144   *
5145   * We need these for threads, so they've been rolled into the core,
5146   * rather than left in POSIX.xs.
5147   *
5148   * (DRS, Oct 23, 1997)
5149   */
5150
5151  /* sigset_t is atomic under VMS, so these routines are easy */
5152/*{{{int my_sigemptyset(sigset_t *) */
5153int my_sigemptyset(sigset_t *set) {
5154    if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5155    *set = 0; return 0;
5156}
5157/*}}}*/
5158
5159
5160/*{{{int my_sigfillset(sigset_t *)*/
5161int my_sigfillset(sigset_t *set) {
5162    int i;
5163    if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5164    for (i = 0; i < NSIG; i++) *set |= (1 << i);
5165    return 0;
5166}
5167/*}}}*/
5168
5169
5170/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5171int my_sigaddset(sigset_t *set, int sig) {
5172    if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5173    if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5174    *set |= (1 << (sig - 1));
5175    return 0;
5176}
5177/*}}}*/
5178
5179
5180/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5181int my_sigdelset(sigset_t *set, int sig) {
5182    if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5183    if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5184    *set &= ~(1 << (sig - 1));
5185    return 0;
5186}
5187/*}}}*/
5188
5189
5190/*{{{int my_sigismember(sigset_t *set, int sig)*/
5191int my_sigismember(sigset_t *set, int sig) {
5192    if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5193    if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5194    *set & (1 << (sig - 1));
5195}
5196/*}}}*/
5197
5198
5199/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5200int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5201    sigset_t tempmask;
5202
5203    /* If set and oset are both null, then things are badly wrong. Bail out. */
5204    if ((oset == NULL) && (set == NULL)) {
5205      set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5206      return -1;
5207    }
5208
5209    /* If set's null, then we're just handling a fetch. */
5210    if (set == NULL) {
5211        tempmask = sigblock(0);
5212    }
5213    else {
5214      switch (how) {
5215      case SIG_SETMASK:
5216        tempmask = sigsetmask(*set);
5217        break;
5218      case SIG_BLOCK:
5219        tempmask = sigblock(*set);
5220        break;
5221      case SIG_UNBLOCK:
5222        tempmask = sigblock(0);
5223        sigsetmask(*oset & ~tempmask);
5224        break;
5225      default:
5226        set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5227        return -1;
5228      }
5229    }
5230
5231    /* Did they pass us an oset? If so, stick our holding mask into it */
5232    if (oset)
5233      *oset = tempmask;
5234 
5235    return 0;
5236}
5237/*}}}*/
5238#endif  /* HOMEGROWN_POSIX_SIGNALS */
5239
5240
5241/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5242 * my_utime(), and flex_stat(), all of which operate on UTC unless
5243 * VMSISH_TIMES is true.
5244 */
5245/* method used to handle UTC conversions:
5246 *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5247 */
5248static int gmtime_emulation_type;
5249/* number of secs to add to UTC POSIX-style time to get local time */
5250static long int utc_offset_secs;
5251
5252/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5253 * in vmsish.h.  #undef them here so we can call the CRTL routines
5254 * directly.
5255 */
5256#undef gmtime
5257#undef localtime
5258#undef time
5259
5260
5261/*
5262 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5263 * qualifier with the extern prefix pragma.  This provisional
5264 * hack circumvents this prefix pragma problem in previous
5265 * precompilers.
5266 */
5267#if defined(__VMS_VER) && __VMS_VER >= 70000000
5268#  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5269#    pragma __extern_prefix save
5270#    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5271#    define gmtime decc$__utctz_gmtime
5272#    define localtime decc$__utctz_localtime
5273#    define time decc$__utc_time
5274#    pragma __extern_prefix restore
5275
5276     struct tm *gmtime(), *localtime();   
5277
5278#  endif
5279#endif
5280
5281
5282static time_t toutc_dst(time_t loc) {
5283  struct tm *rsltmp;
5284
5285  if ((rsltmp = localtime(&loc)) == NULL) return -1;
5286  loc -= utc_offset_secs;
5287  if (rsltmp->tm_isdst) loc -= 3600;
5288  return loc;
5289}
5290#define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5291       ((gmtime_emulation_type || my_time(NULL)), \
5292       (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5293       ((secs) - utc_offset_secs))))
5294
5295static time_t toloc_dst(time_t utc) {
5296  struct tm *rsltmp;
5297
5298  utc += utc_offset_secs;
5299  if ((rsltmp = localtime(&utc)) == NULL) return -1;
5300  if (rsltmp->tm_isdst) utc += 3600;
5301  return utc;
5302}
5303#define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5304       ((gmtime_emulation_type || my_time(NULL)), \
5305       (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5306       ((secs) + utc_offset_secs))))
5307
5308#ifndef RTL_USES_UTC
5309/*
5310 
5311    ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5312        DST starts on 1st sun of april      at 02:00  std time
5313            ends on last sun of october     at 02:00  dst time
5314    see the UCX management command reference, SET CONFIG TIMEZONE
5315    for formatting info.
5316
5317    No, it's not as general as it should be, but then again, NOTHING
5318    will handle UK times in a sensible way.
5319*/
5320
5321
5322/*
5323    parse the DST start/end info:
5324    (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5325*/
5326
5327static char *
5328tz_parse_startend(char *s, struct tm *w, int *past)
5329{
5330    int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5331    int ly, dozjd, d, m, n, hour, min, sec, j, k;
5332    time_t g;
5333
5334    if (!s)    return 0;
5335    if (!w) return 0;
5336    if (!past) return 0;
5337
5338    ly = 0;
5339    if (w->tm_year % 4        == 0) ly = 1;
5340    if (w->tm_year % 100      == 0) ly = 0;
5341    if (w->tm_year+1900 % 400 == 0) ly = 1;
5342    if (ly) dinm[1]++;
5343
5344    dozjd = isdigit(*s);
5345    if (*s == 'J' || *s == 'j' || dozjd) {
5346        if (!dozjd && !isdigit(*++s)) return 0;
5347        d = *s++ - '0';
5348        if (isdigit(*s)) {
5349            d = d*10 + *s++ - '0';
5350            if (isdigit(*s)) {
5351                d = d*10 + *s++ - '0';
5352            }
5353        }
5354        if (d == 0) return 0;
5355        if (d > 366) return 0;
5356        d--;
5357        if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5358        g = d * 86400;
5359        dozjd = 1;
5360    } else if (*s == 'M' || *s == 'm') {
5361        if (!isdigit(*++s)) return 0;
5362        m = *s++ - '0';
5363        if (isdigit(*s)) m = 10*m + *s++ - '0';
5364        if (*s != '.') return 0;
5365        if (!isdigit(*++s)) return 0;
5366        n = *s++ - '0';
5367        if (n < 1 || n > 5) return 0;
5368        if (*s != '.') return 0;
5369        if (!isdigit(*++s)) return 0;
5370        d = *s++ - '0';
5371        if (d > 6) return 0;
5372    }
5373
5374    if (*s == '/') {
5375        if (!isdigit(*++s)) return 0;
5376        hour = *s++ - '0';
5377        if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5378        if (*s == ':') {
5379            if (!isdigit(*++s)) return 0;
5380            min = *s++ - '0';
5381            if (isdigit(*s)) min = 10*min + *s++ - '0';
5382            if (*s == ':') {
5383                if (!isdigit(*++s)) return 0;
5384                sec = *s++ - '0';
5385                if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5386            }
5387        }
5388    } else {
5389        hour = 2;
5390        min = 0;
5391        sec = 0;
5392    }
5393
5394    if (dozjd) {
5395        if (w->tm_yday < d) goto before;
5396        if (w->tm_yday > d) goto after;
5397    } else {
5398        if (w->tm_mon+1 < m) goto before;
5399        if (w->tm_mon+1 > m) goto after;
5400
5401        j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5402        k = d - j; /* mday of first d */
5403        if (k <= 0) k += 7;
5404        k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5405        if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5406        if (w->tm_mday < k) goto before;
5407        if (w->tm_mday > k) goto after;
5408    }
5409
5410    if (w->tm_hour < hour) goto before;
5411    if (w->tm_hour > hour) goto after;
5412    if (w->tm_min  < min)  goto before;
5413    if (w->tm_min  > min)  goto after;
5414    if (w->tm_sec  < sec)  goto before;
5415    goto after;
5416
5417before:
5418    *past = 0;
5419    return s;
5420after:
5421    *past = 1;
5422    return s;
5423}
5424
5425
5426
5427
5428/*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5429
5430static char *
5431tz_parse_offset(char *s, int *offset)
5432{
5433    int hour = 0, min = 0, sec = 0;
5434    int neg = 0;
5435    if (!s) return 0;
5436    if (!offset) return 0;
5437
5438    if (*s == '-') {neg++; s++;}
5439    if (*s == '+') s++;
5440    if (!isdigit(*s)) return 0;
5441    hour = *s++ - '0';
5442    if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5443    if (hour > 24) return 0;
5444    if (*s == ':') {
5445        if (!isdigit(*++s)) return 0;
5446        min = *s++ - '0';
5447        if (isdigit(*s)) min = min*10 + (*s++ - '0');
5448        if (min > 59) return 0;
5449        if (*s == ':') {
5450            if (!isdigit(*++s)) return 0;
5451            sec = *s++ - '0';
5452            if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5453            if (sec > 59) return 0;
5454        }
5455    }
5456
5457    *offset = (hour*60+min)*60 + sec;
5458    if (neg) *offset = -*offset;
5459    return s;
5460}
5461
5462/*
5463    input time is w, whatever type of time the CRTL localtime() uses.
5464    sets dst, the zone, and the gmtoff (seconds)
5465
5466    caches the value of TZ and UCX$TZ env variables; note that
5467    my_setenv looks for these and sets a flag if they're changed
5468    for efficiency.
5469
5470    We have to watch out for the "australian" case (dst starts in
5471    october, ends in april)...flagged by "reverse" and checked by
5472    scanning through the months of the previous year.
5473
5474*/
5475
5476static int
5477tz_parse(time_t *w, int *dst, char *zone, int *gmtoff)
5478{
5479    time_t when;
5480    struct tm *w2;
5481    char *s,*s2;
5482    char *dstzone, *tz, *s_start, *s_end;
5483    int std_off, dst_off, isdst;
5484    int y, dststart, dstend;
5485    static char envtz[1025];  /* longer than any logical, symbol, ... */
5486    static char ucxtz[1025];
5487    static char reversed = 0;
5488
5489    if (!w) return 0;
5490
5491    if (tz_updated) {
5492        tz_updated = 0;
5493        reversed = -1;  /* flag need to check  */
5494        envtz[0] = ucxtz[0] = '\0';
5495        tz = my_getenv("TZ",0);
5496        if (tz) strcpy(envtz, tz);
5497        tz = my_getenv("UCX$TZ",0);
5498        if (tz) strcpy(ucxtz, tz);
5499        if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
5500    }
5501    tz = envtz;
5502    if (!*tz) tz = ucxtz;
5503
5504    s = tz;
5505    while (isalpha(*s)) s++;
5506    s = tz_parse_offset(s, &std_off);
5507    if (!s) return 0;
5508    if (!*s) {                  /* no DST, hurray we're done! */
5509        isdst = 0;
5510        goto done;
5511    }
5512
5513    dstzone = s;
5514    while (isalpha(*s)) s++;
5515    s2 = tz_parse_offset(s, &dst_off);
5516    if (s2) {
5517        s = s2;
5518    } else {
5519        dst_off = std_off - 3600;
5520    }
5521
5522    if (!*s) {      /* default dst start/end?? */
5523        if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
5524            s = strchr(ucxtz,',');
5525        }
5526        if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
5527    }
5528    if (*s != ',') return 0;
5529
5530    when = *w;
5531    when = _toutc(when);      /* convert to utc */
5532    when = when - std_off;    /* convert to pseudolocal time*/
5533
5534    w2 = localtime(&when);
5535    y = w2->tm_year;
5536    s_start = s+1;
5537    s = tz_parse_startend(s_start,w2,&dststart);
5538    if (!s) return 0;
5539    if (*s != ',') return 0;
5540
5541    when = *w;
5542    when = _toutc(when);      /* convert to utc */
5543    when = when - dst_off;    /* convert to pseudolocal time*/
5544    w2 = localtime(&when);
5545    if (w2->tm_year != y) {   /* spans a year, just check one time */
5546        when += dst_off - std_off;
5547        w2 = localtime(&when);
5548    }
5549    s_end = s+1;
5550    s = tz_parse_startend(s_end,w2,&dstend);
5551    if (!s) return 0;
5552
5553    if (reversed == -1) {  /* need to check if start later than end */
5554        int j, ds, de;
5555
5556        when = *w;
5557        if (when < 2*365*86400) {
5558            when += 2*365*86400;
5559        } else {
5560            when -= 365*86400;
5561        }
5562        w2 =localtime(&when);
5563        when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
5564
5565        for (j = 0; j < 12; j++) {
5566            w2 =localtime(&when);
5567            (void) tz_parse_startend(s_start,w2,&ds);
5568            (void) tz_parse_startend(s_end,w2,&de);
5569            if (ds != de) break;
5570            when += 30*86400;
5571        }
5572        reversed = 0;
5573        if (de && !ds) reversed = 1;
5574    }
5575
5576    isdst = dststart && !dstend;
5577    if (reversed) isdst = dststart  || !dstend;
5578
5579done:
5580    if (dst)    *dst = isdst;
5581    if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5582    if (isdst)  tz = dstzone;
5583    if (zone) {
5584        while(isalpha(*tz))  *zone++ = *tz++;
5585        *zone = '\0';
5586    }
5587    return 1;
5588}
5589
5590#endif /* !RTL_USES_UTC */
5591
5592/* my_time(), my_localtime(), my_gmtime()
5593 * By default traffic in UTC time values, using CRTL gmtime() or
5594 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5595 * Note: We need to use these functions even when the CRTL has working
5596 * UTC support, since they also handle C<use vmsish qw(times);>
5597 *
5598 * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
5599 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5600 */
5601
5602/*{{{time_t my_time(time_t *timep)*/
5603time_t my_time(time_t *timep)
5604{
5605  dTHX;
5606  time_t when;
5607  struct tm *tm_p;
5608
5609  if (gmtime_emulation_type == 0) {
5610    int dstnow;
5611    time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
5612                              /* results of calls to gmtime() and localtime() */
5613                              /* for same &base */
5614
5615    gmtime_emulation_type++;
5616    if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5617      char off[LNM$C_NAMLENGTH+1];;
5618
5619      gmtime_emulation_type++;
5620      if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5621        gmtime_emulation_type++;
5622        utc_offset_secs = 0;
5623        Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5624      }
5625      else { utc_offset_secs = atol(off); }
5626    }
5627    else { /* We've got a working gmtime() */
5628      struct tm gmt, local;
5629
5630      gmt = *tm_p;
5631      tm_p = localtime(&base);
5632      local = *tm_p;
5633      utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
5634      utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5635      utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
5636      utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
5637    }
5638  }
5639
5640  when = time(NULL);
5641# ifdef VMSISH_TIME
5642# ifdef RTL_USES_UTC
5643  if (VMSISH_TIME) when = _toloc(when);
5644# else
5645  if (!VMSISH_TIME) when = _toutc(when);
5646# endif
5647# endif
5648  if (timep != NULL) *timep = when;
5649  return when;
5650
5651}  /* end of my_time() */
5652/*}}}*/
5653
5654
5655/*{{{struct tm *my_gmtime(const time_t *timep)*/
5656struct tm *
5657my_gmtime(const time_t *timep)
5658{
5659  dTHX;
5660  char *p;
5661  time_t when;
5662  struct tm *rsltmp;
5663
5664  if (timep == NULL) {
5665    set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5666    return NULL;
5667  }
5668  if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
5669
5670  when = *timep;
5671# ifdef VMSISH_TIME
5672  if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5673#  endif
5674# ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
5675  return gmtime(&when);
5676# else
5677  /* CRTL localtime() wants local time as input, so does no tz correction */
5678  rsltmp = localtime(&when);
5679  if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
5680  return rsltmp;
5681#endif
5682}  /* end of my_gmtime() */
5683/*}}}*/
5684
5685
5686/*{{{struct tm *my_localtime(const time_t *timep)*/
5687struct tm *
5688my_localtime(const time_t *timep)
5689{
5690  dTHX;
5691  time_t when, whenutc;
5692  struct tm *rsltmp;
5693  int dst, offset;
5694
5695  if (timep == NULL) {
5696    set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5697    return NULL;
5698  }
5699  if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
5700  if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5701
5702  when = *timep;
5703# ifdef RTL_USES_UTC
5704# ifdef VMSISH_TIME
5705  if (VMSISH_TIME) when = _toutc(when);
5706# endif
5707  /* CRTL localtime() wants UTC as input, does tz correction itself */
5708  return localtime(&when);
5709 
5710# else /* !RTL_USES_UTC */
5711  whenutc = when;
5712# ifdef VMSISH_TIME
5713  if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
5714  if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
5715# endif
5716  dst = -1;
5717#ifndef RTL_USES_UTC
5718  if (tz_parse(&when, &dst, 0, &offset)) {   /* truelocal determines DST*/
5719      when = whenutc - offset;                   /* pseudolocal time*/
5720  }
5721# endif
5722  /* CRTL localtime() wants local time as input, so does no tz correction */
5723  rsltmp = localtime(&when);
5724  if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5725  return rsltmp;
5726# endif
5727
5728} /*  end of my_localtime() */
5729/*}}}*/
5730
5731/* Reset definitions for later calls */
5732#define gmtime(t)    my_gmtime(t)
5733#define localtime(t) my_localtime(t)
5734#define time(t)      my_time(t)
5735
5736
5737/* my_utime - update modification time of a file
5738 * calling sequence is identical to POSIX utime(), but under
5739 * VMS only the modification time is changed; ODS-2 does not
5740 * maintain access times.  Restrictions differ from the POSIX
5741 * definition in that the time can be changed as long as the
5742 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5743 * no separate checks are made to insure that the caller is the
5744 * owner of the file or has special privs enabled.
5745 * Code here is based on Joe Meadows' FILE utility.
5746 */
5747
5748/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5749 *              to VMS epoch  (01-JAN-1858 00:00:00.00)
5750 * in 100 ns intervals.
5751 */
5752static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5753
5754/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5755int my_utime(char *file, struct utimbuf *utimes)
5756{
5757  dTHX;
5758  register int i;
5759  long int bintime[2], len = 2, lowbit, unixtime,
5760           secscale = 10000000; /* seconds --> 100 ns intervals */
5761  unsigned long int chan, iosb[2], retsts;
5762  char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5763  struct FAB myfab = cc$rms_fab;
5764  struct NAM mynam = cc$rms_nam;
5765#if defined (__DECC) && defined (__VAX)
5766  /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5767   * at least through VMS V6.1, which causes a type-conversion warning.
5768   */
5769#  pragma message save
5770#  pragma message disable cvtdiftypes
5771#endif
5772  struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5773  struct fibdef myfib;
5774#if defined (__DECC) && defined (__VAX)
5775  /* This should be right after the declaration of myatr, but due
5776   * to a bug in VAX DEC C, this takes effect a statement early.
5777   */
5778#  pragma message restore
5779#endif
5780  struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5781                        devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5782                        fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5783
5784  if (file == NULL || *file == '\0') {
5785    set_errno(ENOENT);
5786    set_vaxc_errno(LIB$_INVARG);
5787    return -1;
5788  }
5789  if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5790
5791  if (utimes != NULL) {
5792    /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
5793     * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5794     * Since time_t is unsigned long int, and lib$emul takes a signed long int
5795     * as input, we force the sign bit to be clear by shifting unixtime right
5796     * one bit, then multiplying by an extra factor of 2 in lib$emul().
5797     */
5798    lowbit = (utimes->modtime & 1) ? secscale : 0;
5799    unixtime = (long int) utimes->modtime;
5800#   ifdef VMSISH_TIME
5801    /* If input was UTC; convert to local for sys svc */
5802    if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5803#   endif
5804    unixtime >>= 1;  secscale <<= 1;
5805    retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5806    if (!(retsts & 1)) {
5807      set_errno(EVMSERR);
5808      set_vaxc_errno(retsts);
5809      return -1;
5810    }
5811    retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5812    if (!(retsts & 1)) {
5813      set_errno(EVMSERR);
5814      set_vaxc_errno(retsts);
5815      return -1;
5816    }
5817  }
5818  else {
5819    /* Just get the current time in VMS format directly */
5820    retsts = sys$gettim(bintime);
5821    if (!(retsts & 1)) {
5822      set_errno(EVMSERR);
5823      set_vaxc_errno(retsts);
5824      return -1;
5825    }
5826  }
5827
5828  myfab.fab$l_fna = vmsspec;
5829  myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5830  myfab.fab$l_nam = &mynam;
5831  mynam.nam$l_esa = esa;
5832  mynam.nam$b_ess = (unsigned char) sizeof esa;
5833  mynam.nam$l_rsa = rsa;
5834  mynam.nam$b_rss = (unsigned char) sizeof rsa;
5835
5836  /* Look for the file to be affected, letting RMS parse the file
5837   * specification for us as well.  I have set errno using only
5838   * values documented in the utime() man page for VMS POSIX.
5839   */
5840  retsts = sys$parse(&myfab,0,0);
5841  if (!(retsts & 1)) {
5842    set_vaxc_errno(retsts);
5843    if      (retsts == RMS$_PRV) set_errno(EACCES);
5844    else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5845    else                         set_errno(EVMSERR);
5846    return -1;
5847  }
5848  retsts = sys$search(&myfab,0,0);
5849  if (!(retsts & 1)) {
5850    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5851    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5852    set_vaxc_errno(retsts);
5853    if      (retsts == RMS$_PRV) set_errno(EACCES);
5854    else if (retsts == RMS$_FNF) set_errno(ENOENT);
5855    else                         set_errno(EVMSERR);
5856    return -1;
5857  }
5858
5859  devdsc.dsc$w_length = mynam.nam$b_dev;
5860  devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5861
5862  retsts = sys$assign(&devdsc,&chan,0,0);
5863  if (!(retsts & 1)) {
5864    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5865    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5866    set_vaxc_errno(retsts);
5867    if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
5868    else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
5869    else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
5870    else                               set_errno(EVMSERR);
5871    return -1;
5872  }
5873
5874  fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5875  fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5876
5877  memset((void *) &myfib, 0, sizeof myfib);
5878#if defined(__DECC) || defined(__DECCXX)
5879  for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5880  for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5881  /* This prevents the revision time of the file being reset to the current
5882   * time as a result of our IO$_MODIFY $QIO. */
5883  myfib.fib$l_acctl = FIB$M_NORECORD;
5884#else
5885  for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5886  for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5887  myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5888#endif
5889  retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5890  mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5891  myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5892  _ckvmssts(sys$dassgn(chan));
5893  if (retsts & 1) retsts = iosb[0];
5894  if (!(retsts & 1)) {
5895    set_vaxc_errno(retsts);
5896    if (retsts == SS$_NOPRIV) set_errno(EACCES);
5897    else                      set_errno(EVMSERR);
5898    return -1;
5899  }
5900
5901  return 0;
5902}  /* end of my_utime() */
5903/*}}}*/
5904
5905/*
5906 * flex_stat, flex_fstat
5907 * basic stat, but gets it right when asked to stat
5908 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5909 */
5910
5911/* encode_dev packs a VMS device name string into an integer to allow
5912 * simple comparisons. This can be used, for example, to check whether two
5913 * files are located on the same device, by comparing their encoded device
5914 * names. Even a string comparison would not do, because stat() reuses the
5915 * device name buffer for each call; so without encode_dev, it would be
5916 * necessary to save the buffer and use strcmp (this would mean a number of
5917 * changes to the standard Perl code, to say nothing of what a Perl script
5918 * would have to do.
5919 *
5920 * The device lock id, if it exists, should be unique (unless perhaps compared
5921 * with lock ids transferred from other nodes). We have a lock id if the disk is
5922 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5923 * device names. Thus we use the lock id in preference, and only if that isn't
5924 * available, do we try to pack the device name into an integer (flagged by
5925 * the sign bit (LOCKID_MASK) being set).
5926 *
5927 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5928 * name and its encoded form, but it seems very unlikely that we will find
5929 * two files on different disks that share the same encoded device names,
5930 * and even more remote that they will share the same file id (if the test
5931 * is to check for the same file).
5932 *
5933 * A better method might be to use sys$device_scan on the first call, and to
5934 * search for the device, returning an index into the cached array.
5935 * The number returned would be more intelligable.
5936 * This is probably not worth it, and anyway would take quite a bit longer
5937 * on the first call.
5938 */
5939#define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
5940static mydev_t encode_dev (const char *dev)
5941{
5942  int i;
5943  unsigned long int f;
5944  mydev_t enc;
5945  char c;
5946  const char *q;
5947  dTHX;
5948
5949  if (!dev || !dev[0]) return 0;
5950
5951#if LOCKID_MASK
5952  {
5953    struct dsc$descriptor_s dev_desc;
5954    unsigned long int status, lockid, item = DVI$_LOCKID;
5955
5956    /* For cluster-mounted disks, the disk lock identifier is unique, so we
5957       can try that first. */
5958    dev_desc.dsc$w_length =  strlen (dev);
5959    dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
5960    dev_desc.dsc$b_class =   DSC$K_CLASS_S;
5961    dev_desc.dsc$a_pointer = (char *) dev;
5962    _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5963    if (lockid) return (lockid & ~LOCKID_MASK);
5964  }
5965#endif
5966
5967  /* Otherwise we try to encode the device name */
5968  enc = 0;
5969  f = 1;
5970  i = 0;
5971  for (q = dev + strlen(dev); q--; q >= dev) {
5972    if (isdigit (*q))
5973      c= (*q) - '0';
5974    else if (isalpha (toupper (*q)))
5975      c= toupper (*q) - 'A' + (char)10;
5976    else
5977      continue; /* Skip '$'s */
5978    i++;
5979    if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
5980    if (i>1) f *= 36;
5981    enc += f * (unsigned long int) c;
5982  }
5983  return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
5984
5985}  /* end of encode_dev() */
5986
5987static char namecache[NAM$C_MAXRSS+1];
5988
5989static int
5990is_null_device(name)
5991    const char *name;
5992{
5993    dTHX;
5994    /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5995       The underscore prefix, controller letter, and unit number are
5996       independently optional; for our purposes, the colon punctuation
5997       is not.  The colon can be trailed by optional directory and/or
5998       filename, but two consecutive colons indicates a nodename rather
5999       than a device.  [pr]  */
6000  if (*name == '_') ++name;
6001  if (tolower(*name++) != 'n') return 0;
6002  if (tolower(*name++) != 'l') return 0;
6003  if (tolower(*name) == 'a') ++name;
6004  if (*name == '0') ++name;
6005  return (*name++ == ':') && (*name != ':');
6006}
6007
6008/* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6009/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6010 * subset of the applicable information.
6011 */
6012bool
6013Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6014{
6015  char fname_phdev[NAM$C_MAXRSS+1];
6016  if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6017  else {
6018    char fname[NAM$C_MAXRSS+1];
6019    unsigned long int retsts;
6020    struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6021                            namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6022
6023    /* If the struct mystat is stale, we're OOL; stat() overwrites the
6024       device name on successive calls */
6025    devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6026    devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6027    namdsc.dsc$a_pointer = fname;
6028    namdsc.dsc$w_length = sizeof fname - 1;
6029
6030    retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6031                             &namdsc,&namdsc.dsc$w_length,0,0);
6032    if (retsts & 1) {
6033      fname[namdsc.dsc$w_length] = '\0';
6034/*
6035 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6036 * but if someone has redefined that logical, Perl gets very lost.  Since
6037 * we have the physical device name from the stat buffer, just paste it on.
6038 */
6039      strcpy( fname_phdev, statbufp->st_devnam );
6040      strcat( fname_phdev, strrchr(fname, ':') );
6041
6042      return cando_by_name(bit,effective,fname_phdev);
6043    }
6044    else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6045      Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6046      return FALSE;
6047    }
6048    _ckvmssts(retsts);
6049    return FALSE;  /* Should never get to here */
6050  }
6051}  /* end of cando() */
6052/*}}}*/
6053
6054
6055/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6056I32
6057cando_by_name(I32 bit, Uid_t effective, char *fname)
6058{
6059  static char usrname[L_cuserid];
6060  static struct dsc$descriptor_s usrdsc =
6061         {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6062  char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6063  unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6064  unsigned short int retlen;
6065  dTHX;
6066  struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6067  union prvdef curprv;
6068  struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6069         {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6070  struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6071         {0,0,0,0}};
6072
6073  if (!fname || !*fname) return FALSE;
6074  /* Make sure we expand logical names, since sys$check_access doesn't */
6075  if (!strpbrk(fname,"/]>:")) {
6076    strcpy(fileified,fname);
6077    while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6078    fname = fileified;
6079  }
6080  if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6081  retlen = namdsc.dsc$w_length = strlen(vmsname);
6082  namdsc.dsc$a_pointer = vmsname;
6083  if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6084      vmsname[retlen-1] == ':') {
6085    if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6086    namdsc.dsc$w_length = strlen(fileified);
6087    namdsc.dsc$a_pointer = fileified;
6088  }
6089
6090  if (!usrdsc.dsc$w_length) {
6091    cuserid(usrname);
6092    usrdsc.dsc$w_length = strlen(usrname);
6093  }
6094
6095  switch (bit) {
6096    case S_IXUSR: case S_IXGRP: case S_IXOTH:
6097      access = ARM$M_EXECUTE; break;
6098    case S_IRUSR: case S_IRGRP: case S_IROTH:
6099      access = ARM$M_READ; break;
6100    case S_IWUSR: case S_IWGRP: case S_IWOTH:
6101      access = ARM$M_WRITE; break;
6102    case S_IDUSR: case S_IDGRP: case S_IDOTH:
6103      access = ARM$M_DELETE; break;
6104    default:
6105      return FALSE;
6106  }
6107
6108  retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6109  if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6110      retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6111      retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6112    set_vaxc_errno(retsts);
6113    if (retsts == SS$_NOPRIV) set_errno(EACCES);
6114    else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6115    else set_errno(ENOENT);
6116    return FALSE;
6117  }
6118  if (retsts == SS$_NORMAL) {
6119    if (!privused) return TRUE;
6120    /* We can get access, but only by using privs.  Do we have the
6121       necessary privs currently enabled? */
6122    _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6123    if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
6124    if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
6125                                      !curprv.prv$v_bypass)  return FALSE;
6126    if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
6127         !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
6128    if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6129    return TRUE;
6130  }
6131  if (retsts == SS$_ACCONFLICT) {
6132    return TRUE;
6133  }
6134  _ckvmssts(retsts);
6135
6136  return FALSE;  /* Should never get here */
6137
6138}  /* end of cando_by_name() */
6139/*}}}*/
6140
6141
6142/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6143int
6144flex_fstat(int fd, Stat_t *statbufp)
6145{
6146  dTHX;
6147  if (!fstat(fd,(stat_t *) statbufp)) {
6148    if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6149    statbufp->st_dev = encode_dev(statbufp->st_devnam);
6150#   ifdef RTL_USES_UTC
6151#   ifdef VMSISH_TIME
6152    if (VMSISH_TIME) {
6153      statbufp->st_mtime = _toloc(statbufp->st_mtime);
6154      statbufp->st_atime = _toloc(statbufp->st_atime);
6155      statbufp->st_ctime = _toloc(statbufp->st_ctime);
6156    }
6157#   endif
6158#   else
6159#   ifdef VMSISH_TIME
6160    if (!VMSISH_TIME) { /* Return UTC instead of local time */
6161#   else
6162    if (1) {
6163#   endif
6164      statbufp->st_mtime = _toutc(statbufp->st_mtime);
6165      statbufp->st_atime = _toutc(statbufp->st_atime);
6166      statbufp->st_ctime = _toutc(statbufp->st_ctime);
6167    }
6168#endif
6169    return 0;
6170  }
6171  return -1;
6172
6173}  /* end of flex_fstat() */
6174/*}}}*/
6175
6176/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6177int
6178flex_stat(const char *fspec, Stat_t *statbufp)
6179{
6180    dTHX;
6181    char fileified[NAM$C_MAXRSS+1];
6182    char temp_fspec[NAM$C_MAXRSS+300];
6183    int retval = -1;
6184
6185    strcpy(temp_fspec, fspec);
6186    if (statbufp == (Stat_t *) &PL_statcache)
6187      do_tovmsspec(temp_fspec,namecache,0);
6188    if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6189      memset(statbufp,0,sizeof *statbufp);
6190      statbufp->st_dev = encode_dev("_NLA0:");
6191      statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6192      statbufp->st_uid = 0x00010001;
6193      statbufp->st_gid = 0x0001;
6194      time((time_t *)&statbufp->st_mtime);
6195      statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6196      return 0;
6197    }
6198
6199    /* Try for a directory name first.  If fspec contains a filename without
6200     * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6201     * and sea:[wine.dark]water. exist, we prefer the directory here.
6202     * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6203     * not sea:[wine.dark]., if the latter exists.  If the intended target is
6204     * the file with null type, specify this by calling flex_stat() with
6205     * a '.' at the end of fspec.
6206     */
6207    if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6208      retval = stat(fileified,(stat_t *) statbufp);
6209      if (!retval && statbufp == (Stat_t *) &PL_statcache)
6210        strcpy(namecache,fileified);
6211    }
6212    if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6213    if (!retval) {
6214      statbufp->st_dev = encode_dev(statbufp->st_devnam);
6215#     ifdef RTL_USES_UTC
6216#     ifdef VMSISH_TIME
6217      if (VMSISH_TIME) {
6218        statbufp->st_mtime = _toloc(statbufp->st_mtime);
6219        statbufp->st_atime = _toloc(statbufp->st_atime);
6220        statbufp->st_ctime = _toloc(statbufp->st_ctime);
6221      }
6222#     endif
6223#     else
6224#     ifdef VMSISH_TIME
6225      if (!VMSISH_TIME) { /* Return UTC instead of local time */
6226#     else
6227      if (1) {
6228#     endif
6229        statbufp->st_mtime = _toutc(statbufp->st_mtime);
6230        statbufp->st_atime = _toutc(statbufp->st_atime);
6231        statbufp->st_ctime = _toutc(statbufp->st_ctime);
6232      }
6233#     endif
6234    }
6235    return retval;
6236
6237}  /* end of flex_stat() */
6238/*}}}*/
6239
6240
6241/*{{{char *my_getlogin()*/
6242/* VMS cuserid == Unix getlogin, except calling sequence */
6243char *
6244my_getlogin()
6245{
6246    static char user[L_cuserid];
6247    return cuserid(user);
6248}
6249/*}}}*/
6250
6251
6252/*  rmscopy - copy a file using VMS RMS routines
6253 *
6254 *  Copies contents and attributes of spec_in to spec_out, except owner
6255 *  and protection information.  Name and type of spec_in are used as
6256 *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6257 *  should try to propagate timestamps from the input file to the output file.
6258 *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6259 *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6260 *  propagated to the output file at creation iff the output file specification
6261 *  did not contain an explicit name or type, and the revision date is always
6262 *  updated at the end of the copy operation.  If it is greater than 0, then
6263 *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6264 *  other than the revision date should be propagated, and bit 1 indicates
6265 *  that the revision date should be propagated.
6266 *
6267 *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6268 *
6269 *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6270 *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6271 *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6272 * as part of the Perl standard distribution under the terms of the
6273 * GNU General Public License or the Perl Artistic License.  Copies
6274 * of each may be found in the Perl standard distribution.
6275 */
6276/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6277int
6278Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6279{
6280    char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6281         rsa[NAM$C_MAXRSS], ubf[32256];
6282    unsigned long int i, sts, sts2;
6283    struct FAB fab_in, fab_out;
6284    struct RAB rab_in, rab_out;
6285    struct NAM nam;
6286    struct XABDAT xabdat;
6287    struct XABFHC xabfhc;
6288    struct XABRDT xabrdt;
6289    struct XABSUM xabsum;
6290
6291    if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6292        !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6293      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6294      return 0;
6295    }
6296
6297    fab_in = cc$rms_fab;
6298    fab_in.fab$l_fna = vmsin;
6299    fab_in.fab$b_fns = strlen(vmsin);
6300    fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6301    fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6302    fab_in.fab$l_fop = FAB$M_SQO;
6303    fab_in.fab$l_nam =  &nam;
6304    fab_in.fab$l_xab = (void *) &xabdat;
6305
6306    nam = cc$rms_nam;
6307    nam.nam$l_rsa = rsa;
6308    nam.nam$b_rss = sizeof(rsa);
6309    nam.nam$l_esa = esa;
6310    nam.nam$b_ess = sizeof (esa);
6311    nam.nam$b_esl = nam.nam$b_rsl = 0;
6312
6313    xabdat = cc$rms_xabdat;        /* To get creation date */
6314    xabdat.xab$l_nxt = (void *) &xabfhc;
6315
6316    xabfhc = cc$rms_xabfhc;        /* To get record length */
6317    xabfhc.xab$l_nxt = (void *) &xabsum;
6318
6319    xabsum = cc$rms_xabsum;        /* To get key and area information */
6320
6321    if (!((sts = sys$open(&fab_in)) & 1)) {
6322      set_vaxc_errno(sts);
6323      switch (sts) {
6324        case RMS$_FNF: case RMS$_DNF:
6325          set_errno(ENOENT); break;
6326        case RMS$_DIR:
6327          set_errno(ENOTDIR); break;
6328        case RMS$_DEV:
6329          set_errno(ENODEV); break;
6330        case RMS$_SYN:
6331          set_errno(EINVAL); break;
6332        case RMS$_PRV:
6333          set_errno(EACCES); break;
6334        default:
6335          set_errno(EVMSERR);
6336      }
6337      return 0;
6338    }
6339
6340    fab_out = fab_in;
6341    fab_out.fab$w_ifi = 0;
6342    fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6343    fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6344    fab_out.fab$l_fop = FAB$M_SQO;
6345    fab_out.fab$l_fna = vmsout;
6346    fab_out.fab$b_fns = strlen(vmsout);
6347    fab_out.fab$l_dna = nam.nam$l_name;
6348    fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6349
6350    if (preserve_dates == 0) {  /* Act like DCL COPY */
6351      nam.nam$b_nop = NAM$M_SYNCHK;
6352      fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6353      if (!((sts = sys$parse(&fab_out)) & 1)) {
6354        set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6355        set_vaxc_errno(sts);
6356        return 0;
6357      }
6358      fab_out.fab$l_xab = (void *) &xabdat;
6359      if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6360    }
6361    fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6362    if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6363      preserve_dates =0;      /* bitmask from this point forward   */
6364
6365    if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6366    if (!((sts = sys$create(&fab_out)) & 1)) {
6367      set_vaxc_errno(sts);
6368      switch (sts) {
6369        case RMS$_DNF:
6370          set_errno(ENOENT); break;
6371        case RMS$_DIR:
6372          set_errno(ENOTDIR); break;
6373        case RMS$_DEV:
6374          set_errno(ENODEV); break;
6375        case RMS$_SYN:
6376          set_errno(EINVAL); break;
6377        case RMS$_PRV:
6378          set_errno(EACCES); break;
6379        default:
6380          set_errno(EVMSERR);
6381      }
6382      return 0;
6383    }
6384    fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6385    if (preserve_dates & 2) {
6386      /* sys$close() will process xabrdt, not xabdat */
6387      xabrdt = cc$rms_xabrdt;
6388#ifndef __GNUC__
6389      xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6390#else
6391      /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6392       * is unsigned long[2], while DECC & VAXC use a struct */
6393      memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6394#endif
6395      fab_out.fab$l_xab = (void *) &xabrdt;
6396    }
6397
6398    rab_in = cc$rms_rab;
6399    rab_in.rab$l_fab = &fab_in;
6400    rab_in.rab$l_rop = RAB$M_BIO;
6401    rab_in.rab$l_ubf = ubf;
6402    rab_in.rab$w_usz = sizeof ubf;
6403    if (!((sts = sys$connect(&rab_in)) & 1)) {
6404      sys$close(&fab_in); sys$close(&fab_out);
6405      set_errno(EVMSERR); set_vaxc_errno(sts);
6406      return 0;
6407    }
6408
6409    rab_out = cc$rms_rab;
6410    rab_out.rab$l_fab = &fab_out;
6411    rab_out.rab$l_rbf = ubf;
6412    if (!((sts = sys$connect(&rab_out)) & 1)) {
6413      sys$close(&fab_in); sys$close(&fab_out);
6414      set_errno(EVMSERR); set_vaxc_errno(sts);
6415      return 0;
6416    }
6417
6418    while ((sts = sys$read(&rab_in))) {  /* always true  */
6419      if (sts == RMS$_EOF) break;
6420      rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6421      if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6422        sys$close(&fab_in); sys$close(&fab_out);
6423        set_errno(EVMSERR); set_vaxc_errno(sts);
6424        return 0;
6425      }
6426    }
6427
6428    fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6429    sys$close(&fab_in);  sys$close(&fab_out);
6430    sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6431    if (!(sts & 1)) {
6432      set_errno(EVMSERR); set_vaxc_errno(sts);
6433      return 0;
6434    }
6435
6436    return 1;
6437
6438}  /* end of rmscopy() */
6439/*}}}*/
6440
6441
6442/***  The following glue provides 'hooks' to make some of the routines
6443 * from this file available from Perl.  These routines are sufficiently
6444 * basic, and are required sufficiently early in the build process,
6445 * that's it's nice to have them available to miniperl as well as the
6446 * full Perl, so they're set up here instead of in an extension.  The
6447 * Perl code which handles importation of these names into a given
6448 * package lives in [.VMS]Filespec.pm in @INC.
6449 */
6450
6451void
6452rmsexpand_fromperl(pTHX_ CV *cv)
6453{
6454  dXSARGS;
6455  char *fspec, *defspec = NULL, *rslt;
6456  STRLEN n_a;
6457
6458  if (!items || items > 2)
6459    Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6460  fspec = SvPV(ST(0),n_a);
6461  if (!fspec || !*fspec) XSRETURN_UNDEF;
6462  if (items == 2) defspec = SvPV(ST(1),n_a);
6463
6464  rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6465  ST(0) = sv_newmortal();
6466  if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6467  XSRETURN(1);
6468}
6469
6470void
6471vmsify_fromperl(pTHX_ CV *cv)
6472{
6473  dXSARGS;
6474  char *vmsified;
6475  STRLEN n_a;
6476
6477  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6478  vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6479  ST(0) = sv_newmortal();
6480  if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6481  XSRETURN(1);
6482}
6483
6484void
6485unixify_fromperl(pTHX_ CV *cv)
6486{
6487  dXSARGS;
6488  char *unixified;
6489  STRLEN n_a;
6490
6491  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6492  unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6493  ST(0) = sv_newmortal();
6494  if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6495  XSRETURN(1);
6496}
6497
6498void
6499fileify_fromperl(pTHX_ CV *cv)
6500{
6501  dXSARGS;
6502  char *fileified;
6503  STRLEN n_a;
6504
6505  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6506  fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6507  ST(0) = sv_newmortal();
6508  if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6509  XSRETURN(1);
6510}
6511
6512void
6513pathify_fromperl(pTHX_ CV *cv)
6514{
6515  dXSARGS;
6516  char *pathified;
6517  STRLEN n_a;
6518
6519  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6520  pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6521  ST(0) = sv_newmortal();
6522  if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6523  XSRETURN(1);
6524}
6525
6526void
6527vmspath_fromperl(pTHX_ CV *cv)
6528{
6529  dXSARGS;
6530  char *vmspath;
6531  STRLEN n_a;
6532
6533  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6534  vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6535  ST(0) = sv_newmortal();
6536  if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6537  XSRETURN(1);
6538}
6539
6540void
6541unixpath_fromperl(pTHX_ CV *cv)
6542{
6543  dXSARGS;
6544  char *unixpath;
6545  STRLEN n_a;
6546
6547  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6548  unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6549  ST(0) = sv_newmortal();
6550  if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6551  XSRETURN(1);
6552}
6553
6554void
6555candelete_fromperl(pTHX_ CV *cv)
6556{
6557  dXSARGS;
6558  char fspec[NAM$C_MAXRSS+1], *fsp;
6559  SV *mysv;
6560  IO *io;
6561  STRLEN n_a;
6562
6563  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6564
6565  mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6566  if (SvTYPE(mysv) == SVt_PVGV) {
6567    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6568      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6569      ST(0) = &PL_sv_no;
6570      XSRETURN(1);
6571    }
6572    fsp = fspec;
6573  }
6574  else {
6575    if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6576      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6577      ST(0) = &PL_sv_no;
6578      XSRETURN(1);
6579    }
6580  }
6581
6582  ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6583  XSRETURN(1);
6584}
6585
6586void
6587rmscopy_fromperl(pTHX_ CV *cv)
6588{
6589  dXSARGS;
6590  char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6591  int date_flag;
6592  struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6593                        outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6594  unsigned long int sts;
6595  SV *mysv;
6596  IO *io;
6597  STRLEN n_a;
6598
6599  if (items < 2 || items > 3)
6600    Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6601
6602  mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6603  if (SvTYPE(mysv) == SVt_PVGV) {
6604    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6605      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6606      ST(0) = &PL_sv_no;
6607      XSRETURN(1);
6608    }
6609    inp = inspec;
6610  }
6611  else {
6612    if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6613      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6614      ST(0) = &PL_sv_no;
6615      XSRETURN(1);
6616    }
6617  }
6618  mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6619  if (SvTYPE(mysv) == SVt_PVGV) {
6620    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6621      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6622      ST(0) = &PL_sv_no;
6623      XSRETURN(1);
6624    }
6625    outp = outspec;
6626  }
6627  else {
6628    if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6629      set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6630      ST(0) = &PL_sv_no;
6631      XSRETURN(1);
6632    }
6633  }
6634  date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6635
6636  ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6637  XSRETURN(1);
6638}
6639
6640
6641void
6642mod2fname(CV *cv)
6643{
6644  dXSARGS;
6645  char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6646       workbuff[NAM$C_MAXRSS*1 + 1];
6647  int total_namelen = 3, counter, num_entries;
6648  /* ODS-5 ups this, but we want to be consistent, so... */
6649  int max_name_len = 39;
6650  AV *in_array = (AV *)SvRV(ST(0));
6651
6652  num_entries = av_len(in_array);
6653
6654  /* All the names start with PL_. */
6655  strcpy(ultimate_name, "PL_");
6656
6657  /* Clean up our working buffer */
6658  Zero(work_name, sizeof(work_name), char);
6659
6660  /* Run through the entries and build up a working name */
6661  for(counter = 0; counter <= num_entries; counter++) {
6662    /* If it's not the first name then tack on a __ */
6663    if (counter) {
6664      strcat(work_name, "__");
6665    }
6666    strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6667                           PL_na));
6668  }
6669
6670  /* Check to see if we actually have to bother...*/
6671  if (strlen(work_name) + 3 <= max_name_len) {
6672    strcat(ultimate_name, work_name);
6673  } else {
6674    /* It's too darned big, so we need to go strip. We use the same */
6675    /* algorithm as xsubpp does. First, strip out doubled __ */
6676    char *source, *dest, last;
6677    dest = workbuff;
6678    last = 0;
6679    for (source = work_name; *source; source++) {
6680      if (last == *source && last == '_') {
6681        continue;
6682      }
6683      *dest++ = *source;
6684      last = *source;
6685    }
6686    /* Go put it back */
6687    strcpy(work_name, workbuff);
6688    /* Is it still too big? */
6689    if (strlen(work_name) + 3 > max_name_len) {
6690      /* Strip duplicate letters */
6691      last = 0;
6692      dest = workbuff;
6693      for (source = work_name; *source; source++) {
6694        if (last == toupper(*source)) {
6695        continue;
6696        }
6697        *dest++ = *source;
6698        last = toupper(*source);
6699      }
6700      strcpy(work_name, workbuff);
6701    }
6702
6703    /* Is it *still* too big? */
6704    if (strlen(work_name) + 3 > max_name_len) {
6705      /* Too bad, we truncate */
6706      work_name[max_name_len - 2] = 0;
6707    }
6708    strcat(ultimate_name, work_name);
6709  }
6710
6711  /* Okay, return it */
6712  ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6713  XSRETURN(1);
6714}
6715
6716void
6717init_os_extras()
6718{
6719  char* file = __FILE__;
6720  dTHX;
6721  char temp_buff[512];
6722  if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6723    no_translate_barewords = TRUE;
6724  } else {
6725    no_translate_barewords = FALSE;
6726  }
6727
6728  newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6729  newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6730  newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6731  newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6732  newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6733  newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6734  newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6735  newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6736  newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6737  newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6738
6739  store_pipelocs();
6740
6741  return;
6742}
6743 
6744/*  End of vms.c */
Note: See TracBrowser for help on using the repository browser.