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