vms/vms.c

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