vms/vms.c

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