vms/vms.c

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