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