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