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