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