vms/vms.c

   1 /* VMS-specific routines for perl5
   2  *
   3  * Last revised: 09-Oct-1994
   4  */
   5
   6 #include <acedef.h>
   7 #include <acldef.h>
   8 #include <armdef.h>
   9 #include <chpdef.h>
  10 #include <descrip.h>
  11 #include <dvidef.h>
  12 #include <float.h>
  13 #include <fscndef.h>
  14 #include <iodef.h>
  15 #include <jpidef.h>
  16 #include <libdef.h>
  17 #include <lib$routines.h>
  18 #include <lnmdef.h>
  19 #include <psldef.h>
  20 #include <rms.h>
  21 #include <shrdef.h>
  22 #include <ssdef.h>
  23 #include <starlet.h>
  24 #include <stsdef.h>
  25 #include <syidef.h>
  26
  27
  28 #include "EXTERN.h"
  29 #include "perl.h"
  30
  31 struct itmlst_3 {
  32   unsigned short int buflen;
  33   unsigned short int itmcode;
  34   void *bufadr;
  35   unsigned long int retlen;
  36 };
  37
  38 static unsigned long int sts;
  39
  40 #define _cksts(call) \
  41   if (!(sts=(call))&1) { \
  42     errno = EVMSERR; vaxc$errno = sts; \
  43     croak("fatal error at %s, line %d",__FILE__,__LINE__); \
  44   } else { 1; }
  45
  46 /* my_getenv
  47  * Translate a logical name.  Substitute for CRTL getenv() to avoid
  48  * memory leak, and to keep my_getenv() and my_setenv() in the same
  49  * domain (mostly - my_getenv() need not return a translation from
  50  * the process logical name table)
  51  *
  52  * Note: Uses static buffer -- not thread-safe!
  53  */
  54 /*{{{ char *my_getenv(char *lnm)*/
  55 char *
  56 my_getenv(char *lnm)
  57 {
  58     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
  59     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
  60     unsigned short int eqvlen;
  61     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
  62     $DESCRIPTOR(sysdiskdsc,"SYS$DISK");
  63     $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
  64     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
  65                             eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
  66                                       DSC$K_CLASS_S, __my_getenv_eqv};
  67     struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING,
  68                                  __my_getenv_eqv, &eqvlen, 0, 0, 0, 0};
  69
  70     for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
  71     *cp2 = '\0';
  72     lnmdsc.dsc$w_length = cp1 - lnm;
  73     if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) {
  74       _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst));
  75       eqvdsc.dsc$a_pointer += eqvlen;
  76       eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1;
  77       _cksts(sys$setddir(0,&eqvlen,&eqvdsc));
  78       eqvdsc.dsc$a_pointer[eqvlen] = '\0';
  79       return __my_getenv_eqv;
  80     }
  81     else {
  82       retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
  83       if (retsts != SS$_NOLOGNAM) {
  84         if (retsts & 1) {
  85           __my_getenv_eqv[eqvlen] = '\0';
  86           return __my_getenv_eqv;
  87         }
  88         _cksts(retsts);
  89       }
  90       else {
  91         retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0);
  92         if (retsts != LIB$_NOSUCHSYM) {
  93           /* We want to return only logical names or CRTL Unix emulations */
  94           if (retsts & 1) return Nullch;
  95           _cksts(retsts);
  96         }
  97         else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
  98       }
  99     }
 100     return NULL;
 101
 102 }  /* end of my_getenv() */
 103 /*}}}*/
 104
 105 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 106 void
 107 my_setenv(char *lnm,char *eqv)
 108 /* Define a supervisor-mode logical name in the process table.
 109  * In the future we'll add tables, attribs, and acmodes,
 110  * probably through a different call.
 111  */
 112 {
 113     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 114     unsigned long int retsts, usermode = PSL$C_USER;
 115     $DESCRIPTOR(tabdsc,"LNM$PROCESS");
 116     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 117                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 118
 119     for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
 120     lnmdsc.dsc$w_length = cp1 - lnm;
 121
 122     if (!eqv || !*eqv) {  /* we're deleting a logical name */
 123       retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
 124       if (retsts != SS$_NOLOGNAM) _cksts(retsts);
 125       if (!(retsts & 1)) {
 126         retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
 127         if (retsts != SS$_NOLOGNAM) _cksts(retsts);
 128       }
 129     }
 130     else {
 131       eqvdsc.dsc$w_length = strlen(eqv);
 132       eqvdsc.dsc$a_pointer = eqv;
 133
 134       _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
 135     }
 136
 137 }  /* end of my_setenv() */
 138 /*}}}*/
 139
 140 static char *do_fileify_dirspec(char *, char *, int);
 141 static char *do_tovmsspec(char *, char *, int);
 142
 143 /*{{{int do_rmdir(char *name)*/
 144 int
 145 do_rmdir(char *name)
 146 {
 147     char dirfile[NAM$C_MAXRSS+1];
 148     int retval;
 149     stat_t st;
 150
 151     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 152     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 153     else retval = kill_file(dirfile);
 154     return retval;
 155
 156 }  /* end of do_rmdir */
 157 /*}}}*/
 158
 159 /* kill_file
 160  * Delete any file to which user has control access, regardless of whether
 161  * delete access is explicitly allowed.
 162  * Limitations: User must have write access to parent directory.
 163  *              Does not block signals or ASTs; if interrupted in midstream
 164  *              may leave file with an altered ACL.
 165  * HANDLE WITH CARE!
 166  */
 167 /*{{{int kill_file(char *name)*/
 168 int
 169 kill_file(char *name)
 170 {
 171     char vmsname[NAM$C_MAXRSS+1];
 172     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 173     unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1;
 174     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 175     struct myacedef {
 176       unsigned char ace$b_length;
 177       unsigned char ace$b_type;
 178       unsigned short int ace$w_flags;
 179       unsigned long int ace$l_access;
 180       unsigned long int ace$l_ident;
 181     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 182                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 183       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 184      struct itmlst_3
 185        findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0,
 186                     sizeof oldace, ACL$C_READACE,   &oldace, 0, 0, 0, 0, 0},
 187        addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0},
 188        dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0},
 189        lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0},
 190        ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0};
 191
 192     if (!remove(name)) return 0;  /* Can we just get rid of it? */
 193
 194     /* No, so we get our own UIC to use as a rights identifier,
 195      * and the insert an ACE at the head of the ACL which allows us
 196      * to delete the file.
 197      */
 198     _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0));
 199     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 200     fildsc.dsc$w_length = strlen(vmsname);
 201     fildsc.dsc$a_pointer = vmsname;
 202     cxt = 0;
 203     newace.ace$l_ident = oldace.ace$l_ident;
 204     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 205       errno = EVMSERR;
 206       vaxc$errno = aclsts;
 207       return -1;
 208     }
 209     /* Grab any existing ACEs with this identifier in case we fail */
 210     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 211     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) {
 212       /* Add the new ACE . . . */
 213       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 214         goto yourroom;
 215       if (rmsts = remove(name)) {
 216         /* We blew it - dir with files in it, no write priv for
 217          * parent directory, etc.  Put things back the way they were. */
 218         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 219           goto yourroom;
 220         if (fndsts & 1) {
 221           addlst[0].bufadr = &oldace;
 222           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 223             goto yourroom;
 224         }
 225       }
 226     }
 227
 228     yourroom:
 229     if (rmsts) {
 230       fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 231       if (aclsts & 1) aclsts = fndsts;
 232     }
 233     if (!(aclsts & 1)) {
 234       errno = EVMSERR;
 235       vaxc$errno = aclsts;
 236       return -1;
 237     }
 238
 239     return rmsts;
 240
 241 }  /* end of kill_file() */
 242 /*}}}*/
 243
 244 static void
 245 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 246 {
 247   static unsigned long int mbxbufsiz;
 248   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 249
 250   if (!mbxbufsiz) {
 251     /*
 252      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
 253      * preprocessor consant BUFSIZ from stdio.h as the size of the
 254      * 'pipe' mailbox.
 255      */
 256     _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 257     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
 258   }
 259   _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
 260
 261   _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
 262   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
 263
 264 }  /* end of create_mbx() */
 265
 266 /*{{{  my_popen and my_pclose*/
 267 struct pipe_details
 268 {
 269     struct pipe_details *next;
 270     FILE *fp;
 271     int pid;
 272     unsigned long int completion;
 273 };
 274
 275 static struct pipe_details *open_pipes = NULL;
 276 static $DESCRIPTOR(nl_desc, "NL:");
 277 static int waitpid_asleep = 0;
 278
 279 static void
 280 popen_completion_ast(unsigned long int unused)
 281 {
 282   if (waitpid_asleep) {
 283     waitpid_asleep = 0;
 284     sys$wake(0,0);
 285   }
 286 }
 287
 288 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
 289 FILE *
 290 my_popen(char *cmd, char *mode)
 291 {
 292     char mbxname[64];
 293     unsigned short int chan;
 294     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
 295     struct pipe_details *info;
 296     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
 297                                       DSC$K_CLASS_S, mbxname},
 298                             cmddsc = {0, DSC$K_DTYPE_T,
 299                                       DSC$K_CLASS_S, 0};
 300
 301
 302     New(7001,info,1,struct pipe_details);
 303
 304     info->completion=0;  /* I assume this will remain 0 until terminates */
 305
 306     /* create mailbox */
 307     create_mbx(&chan,&namdsc);
 308
 309     /* open a FILE* onto it */
 310     info->fp=fopen(mbxname, mode);
 311
 312     /* give up other channel onto it */
 313     _cksts(sys$dassgn(chan));
 314
 315     if (!info->fp)
 316         return Nullfp;
 317
 318     cmddsc.dsc$w_length=strlen(cmd);
 319     cmddsc.dsc$a_pointer=cmd;
 320
 321     if (strcmp(mode,"r")==0) {
 322       _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
 323                      0  /* name */, &info->pid, &info->completion,
 324                      0, popen_completion_ast,0,0,0,0));
 325     }
 326     else {
 327       _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */,
 328                      0  /* name */, &info->pid, &info->completion));
 329     }
 330
 331     info->next=open_pipes;  /* prepend to list */
 332     open_pipes=info;
 333
 334     return info->fp;
 335 }
 336 /*}}}*/
 337
 338 /*{{{  I32 my_pclose(FILE *fp)*/
 339 I32 my_pclose(FILE *fp)
 340 {
 341     struct pipe_details *info, *last = NULL;
 342     unsigned long int abort = SS$_TIMEOUT, retsts;
 343
 344     for (info = open_pipes; info != NULL; last = info, info = info->next)
 345         if (info->fp == fp) break;
 346
 347     if (info == NULL)
 348       /* get here => no such pipe open */
 349       croak("my_pclose() - no such pipe open ???");
 350
 351     if (!info->completion) { /* Tap them gently on the shoulder . . .*/
 352       _cksts(sys$forcex(&info->pid,0,&abort));
 353       sleep(1);
 354     }
 355     if (!info->completion)  /* We tried to be nice . . . */
 356       _cksts(sys$delprc(&info->pid));
 357
 358     fclose(info->fp);
 359     /* remove from list of open pipes */
 360     if (last) last->next = info->next;
 361     else open_pipes = info->next;
 362     retsts = info->completion;
 363     Safefree(info);
 364
 365     return retsts;
 366 }  /* end of my_pclose() */
 367
 368 #ifndef HAS_WAITPID
 369 /* sort-of waitpid; use only with popen() */
 370 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
 371 unsigned long int
 372 waitpid(unsigned long int pid, int *statusp, int flags)
 373 {
 374     struct pipe_details *info;
 375     unsigned long int abort = SS$_TIMEOUT;
 376
 377     for (info = open_pipes; info != NULL; info = info->next)
 378         if (info->pid == pid) break;
 379
 380     if (info != NULL) {  /* we know about this child */
 381       while (!info->completion) {
 382         waitpid_asleep = 1;
 383         sys$hiber();
 384       }
 385
 386       *statusp = info->completion;
 387       return pid;
 388     }
 389     else {  /* we haven't heard of this child */
 390       $DESCRIPTOR(intdsc,"0 00:00:01");
 391       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
 392       unsigned long int interval[2];
 393
 394       _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
 395       _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
 396       if (ownerpid != mypid)
 397         croak("pid %d not a child",pid);
 398
 399       _cksts(sys$bintim(&intdsc,interval));
 400       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
 401         _cksts(sys$schdwk(0,0,interval,0));
 402         _cksts(sys$hiber());
 403       }
 404       _cksts(sts);
 405
 406       /* There's no easy way to find the termination status a child we're
 407        * not aware of beforehand.  If we're really interested in the future,
 408        * we can go looking for a termination mailbox, or chase after the
 409        * accounting record for the process.
 410        */
 411       *statusp = 0;
 412       return pid;
 413     }
 414
 415 }  /* end of waitpid() */
 416 #endif
 417 /*}}}*/
 418 /*}}}*/
 419 /*}}}*/
 420
 421 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
 422 char *
 423 my_gconvert(double val, int ndig, int trail, char *buf)
 424 {
 425   static char __gcvtbuf[DBL_DIG+1];
 426   char *loc;
 427
 428   loc = buf ? buf : __gcvtbuf;
 429   if (val) {
 430     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
 431     return gcvt(val,ndig,loc);
 432   }
 433   else {
 434     loc[0] = '0'; loc[1] = '\0';
 435     return loc;
 436   }
 437
 438 }
 439 /*}}}*/
 440
 441 /*
 442 ** The following routines are provided to make life easier when
 443 ** converting among VMS-style and Unix-style directory specifications.
 444 ** All will take input specifications in either VMS or Unix syntax. On
 445 ** failure, all return NULL.  If successful, the routines listed below
 446 ** return a pointer to a static buffer containing the appropriately
 447 ** reformatted spec (and, therefore, subsequent calls to that routine
 448 ** will clobber the result), while the routines of the same names with
 449 ** a _ts suffix appended will return a pointer to a mallocd string
 450 ** containing the appropriately reformatted spec.
 451 ** In all cases, only explicit syntax is altered; no check is made that
 452 ** the resulting string is valid or that the directory in question
 453 ** actually exists.
 454 **
 455 **   fileify_dirspec() - convert a directory spec into the name of the
 456 **     directory file (i.e. what you can stat() to see if it's a dir).
 457 **     The style (VMS or Unix) of the result is the same as the style
 458 **     of the parameter passed in.
 459 **   pathify_dirspec() - convert a directory spec into a path (i.e.
 460 **     what you prepend to a filename to indicate what directory it's in).
 461 **     The style (VMS or Unix) of the result is the same as the style
 462 **     of the parameter passed in.
 463 **   tounixpath() - convert a directory spec into a Unix-style path.
 464 **   tovmspath() - convert a directory spec into a VMS-style path.
 465 **   tounixspec() - convert any file spec into a Unix-style file spec.
 466 **   tovmsspec() - convert any file spec into a VMS-style spec.
 467  */
 468
 469 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
 470 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
 471 {
 472     static char __fileify_retbuf[NAM$C_MAXRSS+1];
 473     unsigned long int dirlen, retlen, addmfd = 0;
 474     char *retspec, *cp1, *cp2, *lastdir;
 475
 476     if (dir == NULL) return NULL;
 477
 478     dirlen = strlen(dir);
 479     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
 480       if (dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
 481         dirlen -= 1;                 /* to last element */
 482         lastdir = strrchr(dir,'/');
 483       }
 484       else {
 485         if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
 486         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
 487           if (toupper(*(cp2+1)) == 'D' &&    /* Yep.  Is it .dir? */
 488               toupper(*(cp2+2)) == 'I' &&
 489               toupper(*(cp2+3)) == 'R') {
 490             if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
 491               if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
 492                 errno = ENOTDIR;                         /* Bzzt. */
 493                 return NULL;
 494               }
 495             }
 496             dirlen = cp2 - dir;
 497           }
 498           else {  /* There's a type, and it's not .dir.  Bzzt. */
 499             errno = ENOTDIR;
 500             return NULL;
 501           }
 502         }
 503         /* If we lead off with a device or rooted logical, add the MFD
 504            if we're specifying a top-level directory. */
 505         if (lastdir && *dir == '/') {
 506           addmfd = 1;
 507           for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
 508             if (*cp1 == '/') {
 509               addmfd = 0;
 510               break;
 511             }
 512           }
 513         }
 514         retlen = dirlen + addmfd ? 13 : 6;
 515         if (buf) retspec = buf;
 516         else if (ts) New(7009,retspec,retlen+6,char);
 517         else retspec = __fileify_retbuf;
 518         if (addmfd) {
 519           dirlen = lastdir - dir;
 520           memcpy(retspec,dir,dirlen);
 521           strcpy(&retspec[dirlen],"/000000");
 522           strcpy(&retspec[dirlen+7],lastdir);
 523         }
 524         else {
 525           memcpy(retspec,dir,dirlen);
 526           retspec[dirlen] = '\0';
 527         }
 528       }
 529       /* We've picked up everything up to the directory file name.
 530          Now just add the type and version, and we're set. */
 531       strcat(retspec,".dir;1");
 532       return retspec;
 533     }
 534     else {  /* VMS-style directory spec */
 535       char esa[NAM$C_MAXRSS+1], term;
 536       unsigned long int sts, cmplen;
 537       struct FAB dirfab = cc$rms_fab;
 538       struct NAM savnam, dirnam = cc$rms_nam;
 539
 540       dirfab.fab$b_fns = strlen(dir);
 541       dirfab.fab$l_fna = dir;
 542       dirfab.fab$l_nam = &dirnam;
 543       dirnam.nam$b_ess = NAM$C_MAXRSS;
 544       dirnam.nam$l_esa = esa;
 545       dirnam.nam$b_nop = NAM$M_SYNCHK;
 546       if (!(sys$parse(&dirfab)&1)) {
 547         errno = EVMSERR;
 548         vaxc$errno = dirfab.fab$l_sts;
 549         return NULL;
 550       }
 551       savnam = dirnam;
 552       if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
 553         /* Yes; fake the fnb bits so we'll check type below */
 554         dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
 555       }
 556       else {
 557         if (dirfab.fab$l_sts != RMS$_FNF) {
 558           errno = EVMSERR;
 559           vaxc$errno = dirfab.fab$l_sts;
 560           return NULL;
 561         }
 562         dirnam = savnam; /* No; just work with potential name */
 563       }
 564
 565       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
 566         /* Yep; check version while we're at it, if it's there. */
 567         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
 568         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
 569           /* Something other than .DIR[;1].  Bzzt. */
 570           errno = ENOTDIR;
 571           return NULL;
 572         }
 573         else {  /* Ok, it was .DIR[;1]; copy over everything up to the */
 574           retlen = dirnam.nam$l_type - esa;           /* file name. */
 575           if (buf) retspec = buf;
 576           else if (ts) New(7010,retspec,retlen+6,char);
 577           else retspec = __fileify_retbuf;
 578           strncpy(retspec,esa,retlen);
 579           retspec[retlen] = '\0';
 580         }
 581       }
 582       else {
 583         /* They didn't explicitly specify the directory file.  Ignore
 584            any file names in the input, pull off the last element of the
 585            directory path, and make it the file name.  If you want to
 586            pay attention to filenames without .dir in the input, just use
 587            ".DIR;1" as a default filespec for the $PARSE */
 588         esa[dirnam.nam$b_esl] = '\0';
 589         if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
 590         if (cp1 == NULL) return NULL; /* should never happen */
 591         term = *cp1;
 592         *cp1 = '\0';
 593         retlen = strlen(esa);
 594         if ((cp1 = strrchr(esa,'.')) != NULL) {
 595           /* There's more than one directory in the path.  Just roll back. */
 596           *cp1 = term;
 597           if (buf) retspec = buf;
 598           else if (ts) New(7011,retspec,retlen+6,char);
 599           else retspec = __fileify_retbuf;
 600           strcpy(retspec,esa);
 601         }
 602         else { /* This is a top-level dir.  Add the MFD to the path. */
 603           if (buf) retspec = buf;
 604           else if (ts) New(7012,retspec,retlen+14,char);
 605           else retspec = __fileify_retbuf;
 606           cp1 = esa;
 607           cp2 = retspec;
 608           while (*cp1 != ':') *(cp2++) = *(cp1++);
 609           strcpy(cp2,":[000000]");
 610           cp1 += 2;
 611           strcpy(cp2+9,cp1);
 612         }
 613       }
 614       /* Again, we've set up the string up through the filename.  Add the
 615          type and version, and we're done. */
 616       strcat(retspec,".DIR;1");
 617       return retspec;
 618     }
 619 }  /* end of do_fileify_dirspec() */
 620 /*}}}*/
 621 /* External entry points */
 622 char *fileify_dirspec(char *dir, char *buf)
 623 { return do_fileify_dirspec(dir,buf,0); }
 624 char *fileify_dirspec_ts(char *dir, char *buf)
 625 { return do_fileify_dirspec(dir,buf,1); }
 626
 627 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
 628 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
 629 {
 630     static char __pathify_retbuf[NAM$C_MAXRSS+1];
 631     unsigned long int retlen;
 632     char *retpath, *cp1, *cp2;
 633
 634     if (dir == NULL) return NULL;
 635
 636     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
 637       if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
 638       if (cp2 = strchr(cp1,'.')) {
 639         if (toupper(*(cp2+1)) == 'D' &&  /* They specified .dir. */
 640             toupper(*(cp2+2)) == 'I' &&  /* Trim it off. */
 641             toupper(*(cp2+3)) == 'R') {
 642           retlen = cp2 - dir + 1;
 643         }
 644         else {  /* Some other file type.  Bzzt. */
 645           errno = ENOTDIR;
 646           return NULL;
 647         }
 648       }
 649       else {  /* No file type present.  Treat the filename as a directory. */
 650         retlen = strlen(dir) + 1;
 651       }
 652       if (buf) retpath = buf;
 653       else if (ts) New(7013,retpath,retlen,char);
 654       else retpath = __pathify_retbuf;
 655       strncpy(retpath,dir,retlen-1);
 656       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
 657         retpath[retlen-1] = '/';      /* with '/', add it. */
 658         retpath[retlen] = '\0';
 659       }
 660       else retpath[retlen-1] = '\0';
 661     }
 662     else {  /* VMS-style directory spec */
 663       char esa[NAM$C_MAXRSS+1];
 664       unsigned long int sts, cmplen;
 665       struct FAB dirfab = cc$rms_fab;
 666       struct NAM savnam, dirnam = cc$rms_nam;
 667
 668       dirfab.fab$b_fns = strlen(dir);
 669       dirfab.fab$l_fna = dir;
 670       dirfab.fab$l_nam = &dirnam;
 671       dirnam.nam$b_ess = sizeof esa;
 672       dirnam.nam$l_esa = esa;
 673       dirnam.nam$b_nop = NAM$M_SYNCHK;
 674       if (!(sys$parse(&dirfab)&1)) {
 675         errno = EVMSERR;
 676         vaxc$errno = dirfab.fab$l_sts;
 677         return NULL;
 678       }
 679       savnam = dirnam;
 680       if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
 681         /* Yes; fake the fnb bits so we'll check type below */
 682         dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
 683       }
 684       else {
 685         if (dirfab.fab$l_sts != RMS$_FNF) {
 686           errno = EVMSERR;
 687           vaxc$errno = dirfab.fab$l_sts;
 688           return NULL;
 689         }
 690         dirnam = savnam; /* No; just work with potential name */
 691       }
 692
 693       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
 694         /* Yep; check version while we're at it, if it's there. */
 695         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
 696         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
 697           /* Something other than .DIR[;1].  Bzzt. */
 698           errno = ENOTDIR;
 699           return NULL;
 700         }
 701         /* OK, the type was fine.  Now pull any file name into the
 702            directory path. */
 703         if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']';
 704         else {
 705           cp1 = strrchr(esa,'>');
 706           *dirnam.nam$l_type = '>';
 707         }
 708         *cp1 = '.';
 709         *(dirnam.nam$l_type + 1) = '\0';
 710         retlen = dirnam.nam$l_type - esa + 2;
 711       }
 712       else {
 713         /* There wasn't a type on the input, so ignore any file names as
 714            well.  If you want to pay attention to filenames without .dir
 715            in the input, just use ".DIR;1" as a default filespec for
 716            the $PARSE and set retlen thus
 717         retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl);
 718         */
 719         retlen = dirnam.nam$l_name - esa;
 720         esa[retlen] = '\0';
 721       }
 722       if (buf) retpath = buf;
 723       else if (ts) New(7014,retpath,retlen,char);
 724       else retpath = __pathify_retbuf;
 725       strcpy(retpath,esa);
 726     }
 727
 728     return retpath;
 729 }  /* end of do_pathify_dirspec() */
 730 /*}}}*/
 731 /* External entry points */
 732 char *pathify_dirspec(char *dir, char *buf)
 733 { return do_pathify_dirspec(dir,buf,0); }
 734 char *pathify_dirspec_ts(char *dir, char *buf)
 735 { return do_pathify_dirspec(dir,buf,1); }
 736
 737 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
 738 static char *do_tounixspec(char *spec, char *buf, int ts)
 739 {
 740   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
 741   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
 742   int devlen, dirlen;
 743
 744   if (spec == NULL || *spec == '\0') return NULL;
 745   if (buf) rslt = buf;
 746   else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
 747   else rslt = __tounixspec_retbuf;
 748   if (strchr(spec,'/') != NULL) {
 749     strcpy(rslt,spec);
 750     return rslt;
 751   }
 752
 753   cp1 = rslt;
 754   cp2 = spec;
 755   dirend = strrchr(spec,']');
 756   if (dirend == NULL) dirend = strrchr(spec,'>');
 757   if (dirend == NULL) dirend = strchr(spec,':');
 758   if (dirend == NULL) {
 759     strcpy(rslt,spec);
 760     return rslt;
 761   }
 762   if (*cp2 != '[') {
 763     *(cp1++) = '/';
 764   }
 765   else {  /* the VMS spec begins with directories */
 766     cp2++;
 767     if (*cp2 == '-') {
 768       while (*cp2 == '-') {
 769         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
 770         cp2++;
 771       }
 772       if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
 773         if (ts) Safefree(rslt);                        /* filespecs like */
 774         errno = EVMSERR; vaxc$errno = RMS$_SYN;        /* [--foo.bar] */
 775         return NULL;
 776       }
 777       cp2++;
 778     }
 779     else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
 780       *(cp1++) = '/';
 781       if (getcwd(tmp,sizeof tmp,1) == NULL) {
 782         if (ts) Safefree(rslt);
 783         return NULL;
 784       }
 785       do {
 786         cp3 = tmp;
 787         while (*cp3 != ':' && *cp3) cp3++;
 788         *(cp3++) = '\0';
 789         if (strchr(cp3,']') != NULL) break;
 790       } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3));
 791       cp3 = tmp;
 792       while (*cp3) *(cp1++) = *(cp3++);
 793       *(cp1++) = '/';
 794       if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
 795         if (ts) Safefree(rslt);
 796         errno = ERANGE;
 797         return NULL;
 798       }
 799     }
 800     else cp2++;
 801   }
 802   for (; cp2 <= dirend; cp2++) {
 803     if (*cp2 == ':') {
 804       *(cp1++) = '/';
 805       if (*(cp2+1) == '[') cp2++;
 806     }
 807     else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
 808     else if (*cp2 == '.') {
 809       *(cp1++) = '/';
 810       while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
 811              *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
 812     }
 813     else if (*cp2 == '-') {
 814       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
 815         while (*cp2 == '-') {
 816           cp2++;
 817           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
 818         }
 819         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
 820           if (ts) Safefree(rslt);                        /* filespecs like */
 821           errno = EVMSERR; vaxc$errno = RMS$_SYN;        /* [--foo.bar] */
 822           return NULL;
 823         }
 824         cp2++;
 825       }
 826       else *(cp1++) = *cp2;
 827     }
 828     else *(cp1++) = *cp2;
 829   }
 830   while (*cp2) *(cp1++) = *(cp2++);
 831   *cp1 = '\0';
 832
 833   return rslt;
 834
 835 }  /* end of do_tounixspec() */
 836 /*}}}*/
 837 /* External entry points */
 838 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
 839 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
 840
 841 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
 842 static char *do_tovmsspec(char *path, char *buf, int ts) {
 843   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
 844   char *rslt, *dirend, *cp1, *cp2;
 845
 846   if (path == NULL || *path == '\0') return NULL;
 847   if (buf) rslt = buf;
 848   else if (ts) New(7016,rslt,strlen(path)+1,char);
 849   else rslt = __tovmsspec_retbuf;
 850   if (strchr(path,']') != NULL || strchr(path,'>') != NULL ||
 851       (dirend = strrchr(path,'/')) == NULL) {
 852     strcpy(rslt,path);
 853     return rslt;
 854   }
 855   cp1 = rslt;
 856   cp2 = path;
 857   if (*cp2 == '/') {
 858     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
 859     *(cp1++) = ':';
 860     *(cp1++) = '[';
 861     cp2++;
 862     }
 863   else {
 864     *(cp1++) = '[';
 865     *(cp1++) = '.';
 866   }
 867   for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2;
 868   *(cp1++) = ']';
 869   cp2++;
 870   while (*cp2) *(cp1++) = *(cp2++);
 871   *cp1 = '\0';
 872
 873   return rslt;
 874
 875 }  /* end of do_tovmsspec() */
 876 /*}}}*/
 877 /* External entry points */
 878 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
 879 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
 880
 881 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
 882 static char *do_tovmspath(char *path, char *buf, int ts) {
 883   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
 884   int vmslen;
 885   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
 886
 887   if (path == NULL || *path == '\0') return NULL;
 888   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
 889   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
 890   if (buf) return buf;
 891   else if (ts) {
 892     vmslen = strlen(vmsified);
 893     New(7017,cp,vmslen,char);
 894     memcpy(cp,vmsified,vmslen);
 895     cp[vmslen] = '\0';
 896     return cp;
 897   }
 898   else {
 899     strcpy(__tovmspath_retbuf,vmsified);
 900     return __tovmspath_retbuf;
 901   }
 902
 903 }  /* end of do_tovmspath() */
 904 /*}}}*/
 905 /* External entry points */
 906 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
 907 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
 908
 909
 910 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
 911 static char *do_tounixpath(char *path, char *buf, int ts) {
 912   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
 913   int unixlen;
 914   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
 915
 916   if (path == NULL || *path == '\0') return NULL;
 917   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
 918   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
 919   if (buf) return buf;
 920   else if (ts) {
 921     unixlen = strlen(unixified);
 922     New(7017,cp,unixlen,char);
 923     memcpy(cp,unixified,unixlen);
 924     cp[unixlen] = '\0';
 925     return cp;
 926   }
 927   else {
 928     strcpy(__tounixpath_retbuf,unixified);
 929     return __tounixpath_retbuf;
 930   }
 931
 932 }  /* end of do_tounixpath() */
 933 /*}}}*/
 934 /* External entry points */
 935 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
 936 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
 937
 938 /*
 939  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
 940  *
 941  *****************************************************************************
 942  *                                                                           *
 943  *  Copyright (C) 1989-1994 by                                               *
 944  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
 945  *                                                                           *
 946  *  Permission is hereby  granted for the reproduction of this software,     *
 947  *  on condition that this copyright notice is included in the reproduction, *
 948  *  and that such reproduction is not for purposes of profit or material     *
 949  *  gain.                                                                    *
 950  *                                                                           *
 951  *  27-Aug-1994 Modified for inclusion in perl5                              *
 952  *              by Charles Bailey  bailey@genetics.upenn.edu                 *
 953  *****************************************************************************
 954  */
 955
 956 /*
 957  * getredirection() is intended to aid in porting C programs
 958  * to VMS (Vax-11 C).  The native VMS environment does not support
 959  * '>' and '<' I/O redirection, or command line wild card expansion,
 960  * or a command line pipe mechanism using the '|' AND background
 961  * command execution '&'.  All of these capabilities are provided to any
 962  * C program which calls this procedure as the first thing in the
 963  * main program.
 964  * The piping mechanism will probably work with almost any 'filter' type
 965  * of program.  With suitable modification, it may useful for other
 966  * portability problems as well.
 967  *
 968  * Author:  Mark Pizzolato      mark@infocomm.com
 969  */
 970 struct list_item
 971     {
 972     struct list_item *next;
 973     char *value;
 974     };
 975
 976 static void add_item(struct list_item **head,
 977                      struct list_item **tail,
 978                      char *value,
 979                      int *count);
 980
 981 static void expand_wild_cards(char *item,
 982                               struct list_item **head,
 983                               struct list_item **tail,
 984                               int *count);
 985
 986 static int background_process(int argc, char **argv);
 987
 988 static void pipe_and_fork(char **cmargv);
 989
 990 /*{{{ void getredirection(int *ac, char ***av)*/
 991 void
 992 getredirection(int *ac, char ***av)
 993 /*
 994  * Process vms redirection arg's.  Exit if any error is seen.
 995  * If getredirection() processes an argument, it is erased
 996  * from the vector.  getredirection() returns a new argc and argv value.
 997  * In the event that a background command is requested (by a trailing "&"),
 998  * this routine creates a background subprocess, and simply exits the program.
 999  *
1000  * Warning: do not try to simplify the code for vms.  The code
1001  * presupposes that getredirection() is called before any data is
1002  * read from stdin or written to stdout.
1003  *
1004  * Normal usage is as follows:
1005  *
1006  *      main(argc, argv)
1007  *      int             argc;
1008  *      char            *argv[];
1009  *      {
1010  *              getredirection(&argc, &argv);
1011  *      }
1012  */
1013 {
1014     int                 argc = *ac;     /* Argument Count         */
1015     char                **argv = *av;   /* Argument Vector        */
1016     char                *ap;            /* Argument pointer       */
1017     int                 j;              /* argv[] index           */
1018     int                 item_count = 0; /* Count of Items in List */
1019     struct list_item    *list_head = 0; /* First Item in List       */
1020     struct list_item    *list_tail;     /* Last Item in List        */
1021     char                *in = NULL;     /* Input File Name          */
1022     char                *out = NULL;    /* Output File Name         */
1023     char                *outmode = "w"; /* Mode to Open Output File */
1024     char                *err = NULL;    /* Error File Name          */
1025     char                *errmode = "w"; /* Mode to Open Error File  */
1026     int                 cmargc = 0;     /* Piped Command Arg Count  */
1027     char                **cmargv = NULL;/* Piped Command Arg Vector */
1028     stat_t              statbuf;        /* fstat buffer             */
1029
1030     /*
1031      * First handle the case where the last thing on the line ends with
1032      * a '&'.  This indicates the desire for the command to be run in a
1033      * subprocess, so we satisfy that desire.
1034      */
1035     ap = argv[argc-1];
1036     if (0 == strcmp("&", ap))
1037         exit(background_process(--argc, argv));
1038     if ('&' == ap[strlen(ap)-1])
1039         {
1040         ap[strlen(ap)-1] = '\0';
1041         exit(background_process(argc, argv));
1042         }
1043     /*
1044      * Now we handle the general redirection cases that involve '>', '>>',
1045      * '<', and pipes '|'.
1046      */
1047     for (j = 0; j < argc; ++j)
1048         {
1049         if (0 == strcmp("<", argv[j]))
1050             {
1051             if (j+1 >= argc)
1052                 {
1053                 errno = EINVAL;
1054                 croak("No input file");
1055                 }
1056             in = argv[++j];
1057             continue;
1058             }
1059         if ('<' == *(ap = argv[j]))
1060             {
1061             in = 1 + ap;
1062             continue;
1063             }
1064         if (0 == strcmp(">", ap))
1065             {
1066             if (j+1 >= argc)
1067                 {
1068                 errno = EINVAL;
1069                 croak("No input file");
1070                 }
1071             out = argv[++j];
1072             continue;
1073             }
1074         if ('>' == *ap)
1075             {
1076             if ('>' == ap[1])
1077                 {
1078                 outmode = "a";
1079                 if ('\0' == ap[2])
1080                     out = argv[++j];
1081                 else
1082                     out = 2 + ap;
1083                 }
1084             else
1085                 out = 1 + ap;
1086             if (j >= argc)
1087                 {
1088                 errno = EINVAL;
1089                 croak("No output file");
1090                 }
1091             continue;
1092             }
1093         if (('2' == *ap) && ('>' == ap[1]))
1094             {
1095             if ('>' == ap[2])
1096                 {
1097                 errmode = "a";
1098                 if ('\0' == ap[3])
1099                     err = argv[++j];
1100                 else
1101                     err = 3 + ap;
1102                 }
1103             else
1104                 if ('\0' == ap[2])
1105                     err = argv[++j];
1106                 else
1107                     err = 1 + ap;
1108             if (j >= argc)
1109                 {
1110                 errno = EINVAL;
1111                 croak("No error file");
1112                 }
1113             continue;
1114             }
1115         if (0 == strcmp("|", argv[j]))
1116             {
1117             if (j+1 >= argc)
1118                 {
1119                 errno = EPIPE;
1120                 croak("No command into which to pipe");
1121                 }
1122             cmargc = argc-(j+1);
1123             cmargv = &argv[j+1];
1124             argc = j;
1125             continue;
1126             }
1127         if ('|' == *(ap = argv[j]))
1128             {
1129             ++argv[j];
1130             cmargc = argc-j;
1131             cmargv = &argv[j];
1132             argc = j;
1133             continue;
1134             }
1135         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1136         }
1137     /*
1138      * Allocate and fill in the new argument vector, Some Unix's terminate
1139      * the list with an extra null pointer.
1140      */
1141     New(7002, argv, item_count+1, char *);
1142     *av = argv;
1143     for (j = 0; j < item_count; ++j, list_head = list_head->next)
1144         argv[j] = list_head->value;
1145     *ac = item_count;
1146     if (cmargv != NULL)
1147         {
1148         if (out != NULL)
1149             {
1150             errno = EINVAL;
1151             croak("'|' and '>' may not both be specified on command line");
1152             }
1153         pipe_and_fork(cmargv);
1154         }
1155
1156     /* Check for input from a pipe (mailbox) */
1157
1158     if (1 == isapipe(0))
1159         {
1160         char mbxname[L_tmpnam];
1161         long int bufsize;
1162         long int dvi_item = DVI$_DEVBUFSIZ;
1163         $DESCRIPTOR(mbxnam, "");
1164         $DESCRIPTOR(mbxdevnam, "");
1165
1166         /* Input from a pipe, reopen it in binary mode to disable       */
1167         /* carriage control processing.                                 */
1168
1169         if (in != NULL)
1170             {
1171             errno = EINVAL;
1172             croak("'|' and '<' may not both be specified on command line");
1173             }
1174         fgetname(stdin, mbxname);
1175         mbxnam.dsc$a_pointer = mbxname;
1176         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1177         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1178         mbxdevnam.dsc$a_pointer = mbxname;
1179         mbxdevnam.dsc$w_length = sizeof(mbxname);
1180         dvi_item = DVI$_DEVNAM;
1181         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1182         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1183         errno = 0;
1184         freopen(mbxname, "rb", stdin);
1185         if (errno != 0)
1186             {
1187             croak("Error reopening pipe (name: %s) in binary mode",mbxname);
1188             }
1189         }
1190     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1191         {
1192         croak("Can't open input file %s",in);
1193         }
1194     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1195         {
1196         croak("Can't open output file %s",out);
1197         }
1198     if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2")))
1199         {
1200         croak("Can't open error file %s",err);
1201         }
1202 #ifdef ARGPROC_DEBUG
1203     fprintf(stderr, "Arglist:\n");
1204     for (j = 0; j < *ac;  ++j)
1205         fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1206 #endif
1207 }  /* end of getredirection() */
1208 /*}}}*/
1209
1210 static void add_item(struct list_item **head,
1211                      struct list_item **tail,
1212                      char *value,
1213                      int *count)
1214 {
1215     if (*head == 0)
1216         {
1217         New(7003,*head,1,struct list_item);
1218         *tail = *head;
1219         }
1220     else {
1221         New(7004,(*tail)->next,1,struct list_item);
1222         *tail = (*tail)->next;
1223         }
1224     (*tail)->value = value;
1225     ++(*count);
1226 }
1227
1228 static void expand_wild_cards(char *item,
1229                               struct list_item **head,
1230                               struct list_item **tail,
1231                               int *count)
1232 {
1233 int expcount = 0;
1234 int context = 0;
1235 int isunix = 0;
1236 int status;
1237 int status_value;
1238 char *had_version;
1239 char *had_device;
1240 int had_directory;
1241 char *devdir;
1242 char vmsspec[NAM$C_MAXRSS+1];
1243 $DESCRIPTOR(filespec, "");
1244 $DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;");
1245 $DESCRIPTOR(resultspec, "");
1246 unsigned long int zero = 0;
1247
1248     if (strcspn(item, "*%") == strlen(item))
1249         {
1250         add_item(head, tail, item, count);
1251         return;
1252         }
1253     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1254     resultspec.dsc$b_class = DSC$K_CLASS_D;
1255     resultspec.dsc$a_pointer = NULL;
1256     if (isunix = strchr(item,'/'))
1257       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1258     if (!isunix || !filespec.dsc$a_pointer)
1259       filespec.dsc$a_pointer = item;
1260     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1261     /*
1262      * Only return version specs, if the caller specified a version
1263      */
1264     had_version = strchr(item, ';');
1265     /*
1266      * Only return device and directory specs, if the caller specifed either.
1267      */
1268     had_device = strchr(item, ':');
1269     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1270
1271     while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1272                                  &defaultspec, 0, &status_value, &zero)))
1273         {
1274         char *string;
1275         char *c;
1276
1277         New(7005,string,resultspec.dsc$w_length+1,char);
1278         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1279         string[resultspec.dsc$w_length] = '\0';
1280         if (NULL == had_version)
1281             *((char *)strrchr(string, ';')) = '\0';
1282         if ((!had_directory) && (had_device == NULL))
1283             {
1284             if (NULL == (devdir = strrchr(string, ']')))
1285                 devdir = strrchr(string, '>');
1286             strcpy(string, devdir + 1);
1287             }
1288         /*
1289          * Be consistent with what the C RTL has already done to the rest of
1290          * the argv items and lowercase all of these names.
1291          */
1292         for (c = string; *c; ++c)
1293             if (isupper(*c))
1294                 *c = tolower(*c);
1295         if (isunix) trim_unixpath(item,string);
1296         add_item(head, tail, string, count);
1297         ++expcount;
1298         }
1299     if (expcount == 0)
1300         add_item(head, tail, item, count);
1301     lib$sfree1_dd(&resultspec);
1302     lib$find_file_end(&context);
1303 }
1304
1305 static int child_st[2];/* Event Flag set when child process completes   */
1306
1307 static short child_chan;/* I/O Channel for Pipe Mailbox         */
1308
1309 static exit_handler(int *status)
1310 {
1311 short iosb[4];
1312
1313     if (0 == child_st[0])
1314         {
1315 #ifdef ARGPROC_DEBUG
1316         fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1317 #endif
1318         fflush(stdout);     /* Have to flush pipe for binary data to    */
1319                             /* terminate properly -- <tp@mccall.com>    */
1320         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1321         sys$dassgn(child_chan);
1322         fclose(stdout);
1323         sys$synch(0, child_st);
1324         }
1325     return(1);
1326 }
1327
1328 static void sig_child(int chan)
1329 {
1330 #ifdef ARGPROC_DEBUG
1331     fprintf(stderr, "Child Completion AST\n");
1332 #endif
1333     if (child_st[0] == 0)
1334         child_st[0] = 1;
1335 }
1336
1337 static struct exit_control_block
1338     {
1339     struct exit_control_block *flink;
1340     int (*exit_routine)();
1341     int arg_count;
1342     int *status_address;
1343     int exit_status;
1344     } exit_block =
1345     {
1346     0,
1347     exit_handler,
1348     1,
1349     &exit_block.exit_status,
1350     0
1351     };
1352
1353 static void pipe_and_fork(char **cmargv)
1354 {
1355     char subcmd[2048];
1356     $DESCRIPTOR(cmddsc, "");
1357     static char mbxname[64];
1358     $DESCRIPTOR(mbxdsc, mbxname);
1359     short iosb[4];
1360     int status;
1361     int pid, j;
1362     short dvi_item = DVI$_DEVNAM;
1363     unsigned long int zero = 0, one = 1;
1364
1365     strcpy(subcmd, cmargv[0]);
1366     for (j = 1; NULL != cmargv[j]; ++j)
1367         {
1368         strcat(subcmd, " \"");
1369         strcat(subcmd, cmargv[j]);
1370         strcat(subcmd, "\"");
1371         }
1372     cmddsc.dsc$a_pointer = subcmd;
1373     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1374
1375         create_mbx(&child_chan,&mbxdsc);
1376 #ifdef ARGPROC_DEBUG
1377     fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1378     fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1379 #endif
1380     if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1381                                         0, &pid, child_st, &zero, sig_child,
1382                                         &child_chan))))
1383         {
1384         errno = EVMSERR;
1385         croak("Can't spawn subprocess");
1386         }
1387 #ifdef ARGPROC_DEBUG
1388     fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1389 #endif
1390     sys$dclexh(&exit_block);
1391     if (NULL == freopen(mbxname, "wb", stdout))
1392         {
1393         croak("Can't open pipe mailbox for output");
1394         }
1395 }
1396
1397 static int background_process(int argc, char **argv)
1398 {
1399 char command[2048] = "$";
1400 $DESCRIPTOR(value, "");
1401 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1402 static $DESCRIPTOR(null, "NLA0:");
1403 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1404 char pidstring[80];
1405 $DESCRIPTOR(pidstr, "");
1406 int pid;
1407 unsigned long int flags = 17, one = 1;
1408
1409     strcat(command, argv[0]);
1410     while (--argc)
1411         {
1412         strcat(command, " \"");
1413         strcat(command, *(++argv));
1414         strcat(command, "\"");
1415         }
1416     value.dsc$a_pointer = command;
1417     value.dsc$w_length = strlen(value.dsc$a_pointer);
1418     if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value))))
1419         {
1420         errno = EVMSERR;
1421         croak("Can't create symbol for subprocess command");
1422         }
1423     if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) &&
1424         (vaxc$errno != 0x38250))
1425         {
1426         errno = EVMSERR;
1427         croak("Can't spawn subprocess");
1428         }
1429     if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */
1430         if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid))))
1431             {
1432             errno = EVMSERR;
1433             croak("Can't spawn subprocess");
1434             }
1435 #ifdef ARGPROC_DEBUG
1436     fprintf(stderr, "%s\n", command);
1437 #endif
1438     sprintf(pidstring, "%08X", pid);
1439     fprintf(stderr, "%s\n", pidstring);
1440     pidstr.dsc$a_pointer = pidstring;
1441     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1442     lib$set_symbol(&pidsymbol, &pidstr);
1443     return(SS$_NORMAL);
1444 }
1445 /*}}}*/
1446 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1447
1448 /*
1449  * flex_stat, flex_fstat
1450  * basic stat, but gets it right when asked to stat
1451  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
1452  */
1453
1454 static char namecache[NAM$C_MAXRSS+1];
1455
1456 static int
1457 is_null_device(name)
1458     const char *name;
1459 {
1460     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
1461        The underscore prefix, controller letter, and unit number are
1462        independently optional; for our purposes, the colon punctuation
1463        is not.  The colon can be trailed by optional directory and/or
1464        filename, but two consecutive colons indicates a nodename rather
1465        than a device.  [pr]  */
1466   if (*name == '_') ++name;
1467   if (tolower(*name++) != 'n') return 0;
1468   if (tolower(*name++) != 'l') return 0;
1469   if (tolower(*name) == 'a') ++name;
1470   if (*name == '0') ++name;
1471   return (*name++ == ':') && (*name != ':');
1472 }
1473
1474 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
1475 int
1476 flex_fstat(int fd, struct stat *statbuf)
1477 {
1478   char fspec[NAM$C_MAXRSS+1];
1479
1480   if (!getname(fd,fspec)) return -1;
1481   return flex_stat(fspec,statbuf);
1482
1483 }  /* end of flex_fstat() */
1484 /*}}}*/
1485
1486 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
1487 flex_stat(char *fspec, struct stat *statbufp)
1488 {
1489     char fileified[NAM$C_MAXRSS+1];
1490     int retval,myretval;
1491     struct stat tmpbuf;
1492
1493
1494     if (statbufp == &statcache) strcpy(namecache,fspec);
1495     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
1496       memset(statbufp,0,sizeof *statbufp);
1497       statbufp->st_dev = "_NLA0:";
1498       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
1499       statbufp->st_uid = 0x00010001;
1500       statbufp->st_gid = 0x0001;
1501       time(&statbufp->st_mtime);
1502       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
1503       return 0;
1504     }
1505     if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
1506     else {
1507       myretval = stat(fileified,&tmpbuf);
1508     }
1509     retval = stat(fspec,statbufp);
1510     if (!myretval) {
1511       if (retval == -1) {
1512         *statbufp = tmpbuf;
1513         retval = 0;
1514       }
1515       else if (!retval) { /* Dir with same name.  Substitute it. */
1516         statbufp->st_mode &= ~S_IFDIR;
1517         statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
1518         strcpy(namecache,fileified);
1519       }
1520     }
1521     return retval;
1522
1523 }  /* end of flex_stat() */
1524 /*}}}*/
1525
1526 /* trim_unixpath()
1527  * Trim Unix-style prefix off filespec, so it looks like what a shell
1528  * glob expansion would return (i.e. from specified prefix on, not
1529  * full path).  Note that returned filespec is Unix-style, regardless
1530  * of whether input filespec was VMS-style or Unix-style.
1531  *
1532  * Returns !=0 on success, 0 on failure.
1533  */
1534 /*{{{int trim_unixpath(char *template, char *fspec)*/
1535 int
1536 trim_unixpath(char *template, char *fspec)
1537 {
1538   char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1539   register int tmplen;
1540
1541   if (strpbrk(fspec,"]>:") != NULL) {
1542     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1543     else base = unixified;
1544   }
1545   else base = fspec;
1546   for (cp2 = base; *cp2; cp2++) ;  /* Find end of filespec */
1547
1548   /* Find prefix to template consisting of path elements without wildcards */
1549   if ((cp1 = strpbrk(template,"*%?")) == NULL)
1550     for (cp1 = template; *cp1; cp1++) ;
1551   else while (cp1 >= template && *cp1 != '/') cp1--;
1552   if (cp1 == template) return 1;  /* Wildcard was up front - no prefix to clip */
1553   tmplen = cp1 - template;
1554
1555   /* Try to find template prefix on filespec */
1556   if (!memcmp(base,template,tmplen)) return 1;  /* Nothing before prefix - we're done */
1557   for (; cp2 - base > tmplen; base++) {
1558      if (*base != '/') continue;
1559      if (!memcmp(base + 1,template,tmplen)) break;
1560   }
1561   if (cp2 - base == tmplen) return 0;  /* Not there - not good */
1562   base++;  /* Move past leading '/' */
1563   /* Copy down remaining portion of filespec, including trailing NUL */
1564   memmove(fspec,base,cp2 - base + 1);
1565   return 1;
1566
1567 }  /* end of trim_unixpath() */
1568 /*}}}*/
1569
1570 /* Do the permissions allow some operation?  Assumes statcache already set. */
1571 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
1572  * subset of the applicable information.
1573  */
1574 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
1575 I32
1576 cando(I32 bit, I32 effective, struct stat *statbufp)
1577 {
1578   unsigned long int objtyp = ACL$C_FILE, access, retsts;
1579   unsigned short int retlen;
1580   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache};
1581   static char usrname[L_cuserid];
1582   static struct dsc$descriptor_s usrdsc =
1583          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
1584   struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen,
1585                                            0,           0,       0,       0};
1586
1587   if (!usrdsc.dsc$w_length) {
1588     cuserid(usrname);
1589     usrdsc.dsc$w_length = strlen(usrname);
1590   }
1591   namdsc.dsc$w_length = strlen(namecache);
1592   switch (bit) {
1593     case S_IXUSR:
1594     case S_IXGRP:
1595     case S_IXOTH:
1596       access = ARM$M_EXECUTE;
1597       break;
1598     case S_IRUSR:
1599     case S_IRGRP:
1600     case S_IROTH:
1601       access = ARM$M_READ;
1602       break;
1603     case S_IWUSR:
1604     case S_IWGRP:
1605     case S_IWOTH:
1606       access = ARM$M_READ;
1607       break;
1608     default:
1609       return FALSE;
1610   }
1611
1612   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
1613   if (retsts == SS$_NORMAL) return TRUE;
1614   if (retsts == SS$_NOPRIV) return FALSE;
1615   _cksts(retsts);
1616
1617   return FALSE;  /* Should never get here */
1618
1619 }  /* end of cando() */
1620 /*}}}*/
1621
1622 /*
1623  *  VMS readdir() routines.
1624  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1625  *  This code has no copyright.
1626  *
1627  *  21-Jul-1994  Charles Bailey  bailey@genetics.upenn.edu
1628  *  Minor modifications to original routines.
1629  */
1630
1631     /* Number of elements in vms_versions array */
1632 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
1633
1634 /*
1635  *  Open a directory, return a handle for later use.
1636  */
1637 /*{{{ DIR *opendir(char*name) */
1638 DIR *
1639 opendir(char *name)
1640 {
1641     DIR *dd;
1642     char dir[NAM$C_MAXRSS+1];
1643
1644     /* Get memory for the handle, and the pattern. */
1645     New(7006,dd,1,DIR);
1646     if (do_tovmspath(name,dir,0) == NULL) {
1647       Safefree((char *)dd);
1648       return(NULL);
1649     }
1650     New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1651
1652     /* Fill in the fields; mainly playing with the descriptor. */
1653     (void)sprintf(dd->pattern, "%s*.*",dir);
1654     dd->context = 0;
1655     dd->count = 0;
1656     dd->vms_wantversions = 0;
1657     dd->pat.dsc$a_pointer = dd->pattern;
1658     dd->pat.dsc$w_length = strlen(dd->pattern);
1659     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1660     dd->pat.dsc$b_class = DSC$K_CLASS_S;
1661
1662     return dd;
1663 }  /* end of opendir() */
1664 /*}}}*/
1665
1666 /*
1667  *  Set the flag to indicate we want versions or not.
1668  */
1669 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1670 void
1671 vmsreaddirversions(DIR *dd, int flag)
1672 {
1673     dd->vms_wantversions = flag;
1674 }
1675 /*}}}*/
1676
1677 /*
1678  *  Free up an opened directory.
1679  */
1680 /*{{{ void closedir(DIR *dd)*/
1681 void
1682 closedir(DIR *dd)
1683 {
1684     (void)lib$find_file_end(&dd->context);
1685     Safefree(dd->pattern);
1686     Safefree((char *)dd);
1687 }
1688 /*}}}*/
1689
1690 /*
1691  *  Collect all the version numbers for the current file.
1692  */
1693 static void
1694 collectversions(dd)
1695     DIR *dd;
1696 {
1697     struct dsc$descriptor_s     pat;
1698     struct dsc$descriptor_s     res;
1699     struct dirent *e;
1700     char *p, *text, buff[sizeof dd->entry.d_name];
1701     int i;
1702     unsigned long context, tmpsts;
1703
1704     /* Convenient shorthand. */
1705     e = &dd->entry;
1706
1707     /* Add the version wildcard, ignoring the "*.*" put on before */
1708     i = strlen(dd->pattern);
1709     New(7008,text,i + e->d_namlen + 3,char);
1710     (void)strcpy(text, dd->pattern);
1711     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1712
1713     /* Set up the pattern descriptor. */
1714     pat.dsc$a_pointer = text;
1715     pat.dsc$w_length = i + e->d_namlen - 1;
1716     pat.dsc$b_dtype = DSC$K_DTYPE_T;
1717     pat.dsc$b_class = DSC$K_CLASS_S;
1718
1719     /* Set up result descriptor. */
1720     res.dsc$a_pointer = buff;
1721     res.dsc$w_length = sizeof buff - 2;
1722     res.dsc$b_dtype = DSC$K_DTYPE_T;
1723     res.dsc$b_class = DSC$K_CLASS_S;
1724
1725     /* Read files, collecting versions. */
1726     for (context = 0, e->vms_verscount = 0;
1727          e->vms_verscount < VERSIZE(e);
1728          e->vms_verscount++) {
1729         tmpsts = lib$find_file(&pat, &res, &context);
1730         if (tmpsts == RMS$_NMF || context == 0) break;
1731         _cksts(tmpsts);
1732         buff[sizeof buff - 1] = '\0';
1733         if (p = strchr(buff, ';'))
1734             e->vms_versions[e->vms_verscount] = atoi(p + 1);
1735         else
1736             e->vms_versions[e->vms_verscount] = -1;
1737     }
1738
1739     _cksts(lib$find_file_end(&context));
1740     Safefree(text);
1741
1742 }  /* end of collectversions() */
1743
1744 /*
1745  *  Read the next entry from the directory.
1746  */
1747 /*{{{ struct dirent *readdir(DIR *dd)*/
1748 struct dirent *
1749 readdir(DIR *dd)
1750 {
1751     struct dsc$descriptor_s     res;
1752     char *p, buff[sizeof dd->entry.d_name];
1753     int i;
1754     unsigned long int tmpsts;
1755
1756     /* Set up result descriptor, and get next file. */
1757     res.dsc$a_pointer = buff;
1758     res.dsc$w_length = sizeof buff - 2;
1759     res.dsc$b_dtype = DSC$K_DTYPE_T;
1760     res.dsc$b_class = DSC$K_CLASS_S;
1761     dd->count++;
1762     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
1763     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
1764
1765     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
1766     buff[sizeof buff - 1] = '\0';
1767     for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
1768     *p = '\0';
1769
1770     /* Skip any directory component and just copy the name. */
1771     if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1);
1772     else (void)strcpy(dd->entry.d_name, buff);
1773
1774     /* Clobber the version. */
1775     if (p = strchr(dd->entry.d_name, ';')) *p = '\0';
1776
1777     dd->entry.d_namlen = strlen(dd->entry.d_name);
1778     dd->entry.vms_verscount = 0;
1779     if (dd->vms_wantversions) collectversions(dd);
1780     return &dd->entry;
1781
1782 }  /* end of readdir() */
1783 /*}}}*/
1784
1785 /*
1786  *  Return something that can be used in a seekdir later.
1787  */
1788 /*{{{ long telldir(DIR *dd)*/
1789 long
1790 telldir(DIR *dd)
1791 {
1792     return dd->count;
1793 }
1794 /*}}}*/
1795
1796 /*
1797  *  Return to a spot where we used to be.  Brute force.
1798  */
1799 /*{{{ void seekdir(DIR *dd,long count)*/
1800 void
1801 seekdir(DIR *dd, long count)
1802 {
1803     int vms_wantversions;
1804     unsigned long int tmpsts;
1805
1806     /* If we haven't done anything yet... */
1807     if (dd->count == 0)
1808         return;
1809
1810     /* Remember some state, and clear it. */
1811     vms_wantversions = dd->vms_wantversions;
1812     dd->vms_wantversions = 0;
1813     _cksts(lib$find_file_end(&dd->context));
1814     dd->context = 0;
1815
1816     /* The increment is in readdir(). */
1817     for (dd->count = 0; dd->count < count; )
1818         (void)readdir(dd);
1819
1820     dd->vms_wantversions = vms_wantversions;
1821
1822 }  /* end of seekdir() */
1823 /*}}}*/
1824
1825 /* VMS subprocess management
1826  *
1827  * my_vfork() - just a vfork(), after setting a flag to record that
1828  * the current script is trying a Unix-style fork/exec.
1829  *
1830  * vms_do_aexec() and vms_do_exec() are called in response to the
1831  * perl 'exec' function.  If this follows a vfork call, then they
1832  * call out the the regular perl routines in doio.c which do an
1833  * execvp (for those who really want to try this under VMS).
1834  * Otherwise, they do exactly what the perl docs say exec should
1835  * do - terminate the current script and invoke a new command
1836  * (See below for notes on command syntax.)
1837  *
1838  * do_aspawn() and do_spawn() implement the VMS side of the perl
1839  * 'system' function.
1840  *
1841  * Note on command arguments to perl 'exec' and 'system': When handled
1842  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
1843  * are concatenated to form a DCL command string.  If the first arg
1844  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
1845  * the the command string is hrnded off to DCL directly.  Otherwise,
1846  * the first token of the command is taken as the filespec of an image
1847  * to run.  The filespec is expanded using a default type of '.EXE' and
1848  * the process defaults for device, directory, etc., and the resultant
1849  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
1850  * the command string as parameters.  This is perhaps a bit compicated,
1851  * but I hope it will form a happy medium between what VMS folks expect
1852  * from lib$spawn and what Unix folks expect from exec.
1853  */
1854
1855 static int vfork_called;
1856
1857 /*{{{int my_vfork()*/
1858 int
1859 my_vfork()
1860 {
1861   vfork_called = 1;
1862   return vfork();
1863 }
1864 /*}}}*/
1865
1866 static void
1867 setup_argstr(SV *really, SV **mark, SV **sp, char **argstr)
1868 {
1869   char *tmps, *junk;
1870   register size_t cmdlen = 0;
1871   size_t rlen;
1872   register SV **idx;
1873
1874   idx = mark;
1875   if (really && *(tmps = SvPV(really,rlen))) {
1876     cmdlen += rlen + 1;
1877     idx++;
1878   }
1879
1880   for (idx++; idx <= sp; idx++) {
1881     if (*idx) {
1882       junk = SvPVx(*idx,rlen);
1883       cmdlen += rlen ? rlen + 1 : 0;
1884     }
1885   }
1886   New(401,*argstr,cmdlen, char);
1887
1888   if (*tmps) {
1889     strcpy(*argstr,tmps);
1890     mark++;
1891   }
1892   else **argstr = '\0';
1893   while (++mark <= sp) {
1894     if (*mark) {
1895       strcat(*argstr," ");
1896       strcat(*argstr,SvPVx(*mark,na));
1897     }
1898   }
1899
1900 }  /* end of setup_argstr() */
1901
1902 static unsigned long int
1903 setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img)
1904 {
1905   char resspec[NAM$C_MAXRSS+1];
1906   $DESCRIPTOR(defdsc,".EXE");
1907   $DESCRIPTOR(resdsc,resspec);
1908   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1909   unsigned long int cxt = 0, flags = 1, retsts;
1910   register char *s, *rest, *cp;
1911   register int isdcl = 0;
1912
1913   s = cmd;
1914   while (*s && isspace(*s)) s++;
1915   if (check_img) {
1916     if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
1917       isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
1918       for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
1919         if (*cp == ':' || *cp == '[' || *cp == '<') {
1920           isdcl = 0;
1921           break;
1922         }
1923       }
1924     }
1925   }
1926   else isdcl = 1;
1927   if (isdcl) {  /* It's a DCL command, just do it. */
1928     cmddsc->dsc$a_pointer = cmd;
1929     cmddsc->dsc$w_length = strlen(cmd);
1930   }
1931   else {                           /* assume first token is an image spec */
1932     cmd = s;
1933     while (*s && !isspace(*s)) s++;
1934     rest = *s ? s : 0;
1935     imgdsc.dsc$a_pointer = cmd;
1936     imgdsc.dsc$w_length = s - cmd;
1937     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
1938     if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
1939     else {
1940       _cksts(retsts);
1941       _cksts(lib$find_file_end(&cxt));
1942       s = resspec;
1943       while (*s && !isspace(*s)) s++;
1944       *s = '\0';
1945       New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char);
1946       strcpy(Cmd,"$ MCR ");
1947       strcat(Cmd,resspec);
1948       if (rest) strcat(Cmd,rest);
1949       cmddsc->dsc$a_pointer = Cmd;
1950       cmddsc->dsc$w_length = strlen(Cmd);
1951     }
1952   }
1953
1954   return SS$_NORMAL;
1955 }  /* end of setup_cmddsc() */
1956
1957 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
1958 bool
1959 vms_do_aexec(SV *really,SV **mark,SV **sp)
1960 {
1961
1962   if (sp > mark) {
1963     if (vfork_called) {           /* this follows a vfork - act Unixish */
1964       vfork_called = 0;
1965       do_aexec(really,mark,sp);
1966     }
1967     else {                        /* no vfork - act VMSish */
1968       setup_argstr(really,mark,sp,&Argv);
1969       return vms_do_exec(Argv);
1970     }
1971   }
1972
1973   return FALSE;
1974 }  /* end of vms_do_aexec() */
1975 /*}}}*/
1976
1977 /* {{{bool vms_do_exec(char *cmd) */
1978 bool
1979 vms_do_exec(char *cmd)
1980 {
1981
1982   if (vfork_called) {             /* this follows a vfork - act Unixish */
1983     vfork_called = 0;
1984     do_exec(cmd);
1985   }
1986   else {                          /* no vfork - act VMSish */
1987     struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1988
1989     if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1)
1990       vaxc$errno = lib$do_command(&cmddsc);
1991
1992     errno = EVMSERR;
1993     if (dowarn)
1994       warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
1995     do_execfree();
1996   }
1997
1998   return FALSE;
1999
2000 }  /* end of vms_do_exec() */
2001 /*}}}*/
2002
2003 unsigned long int do_spawn(char *);
2004
2005 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2006 unsigned long int
2007 do_aspawn(SV *really,SV **mark,SV **sp)
2008 {
2009
2010   if (sp > mark) {
2011     setup_argstr(really,mark,sp,&Argv);
2012     return do_spawn(Argv);
2013   }
2014
2015   return SS$_ABORT;
2016 }  /* end of do_aspawn() */
2017 /*}}}*/
2018
2019 /* {{{unsigned long int do_spawn(char *cmd) */
2020 unsigned long int
2021 do_spawn(char *cmd)
2022 {
2023   struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2024   unsigned long int substs;
2025
2026   if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1)
2027     _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0));
2028
2029   if (!(substs&1)) {
2030     vaxc$errno = substs;
2031     errno = EVMSERR;
2032     if (dowarn)
2033       warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
2034   }
2035   return substs;
2036
2037 }  /* end of do_spawn() */
2038 /*}}}*/
2039
2040 /*
2041  * A simple fwrite replacement which outputs itmsz*nitm chars without
2042  * introducing record boundaries every itmsz chars.
2043  */
2044 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2045 int
2046 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2047 {
2048   register char *cp, *end;
2049
2050   end = (char *)src + itmsz * nitm;
2051
2052   while ((char *)src <= end) {
2053     for (cp = src; cp <= end; cp++) if (!*cp) break;
2054     if (fputs(src,dest) == EOF) return EOF;
2055     if (cp < end)
2056       if (fputc('\0',dest) == EOF) return EOF;
2057     src = cp + 1;
2058   }
2059
2060   return 1;
2061
2062 }  /* end of my_fwrite() */
2063 /*}}}*/
2064
2065 #ifndef VMS_DO_SOCKETS
2066 /***** The following two routines are temporary, and should be removed,
2067  * along with the corresponding #defines in vmsish.h, when TCP/IP support
2068  * has been added to the VMS port of perl5.  (The temporary hacks are
2069  * here now sho that pack can handle type N elements.)
2070  * - C. Bailey 16-Aug-1994
2071  *****/
2072
2073 /*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/
2074 unsigned short int
2075 tmp_shortflip(unsigned short int val)
2076 {
2077     return val << 8 | val >> 8;
2078 }
2079 /*}}}*/
2080
2081 /*{{{ unsigned long int tmp_longflip(unsigned long int val)*/
2082 unsigned long int
2083 tmp_longflip(unsigned long int val)
2084 {
2085     unsigned long int scratch = val;
2086     unsigned char savbyte, *tmp;
2087
2088     tmp = (unsigned char *) &scratch;
2089     savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte;
2090     savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte;
2091
2092     return scratch;
2093 }
2094 /*}}}*/
2095 #endif