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