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