vms/vms.c

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