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