vms/vms.c

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