vms/vms.c

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