vms/vms.c

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