vms/vms.c

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