vms/vms.c

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