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