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