exp_command.c

   1 /* exp_command.c - the bulk of the Expect commands
   2
   3 Written by: Don Libes, NIST, 2/6/90
   4
   5 Design and implementation of this program was paid for by U.S. tax
   6 dollars.  Therefore it is public domain.  However, the author and NIST
   7 would appreciate credit if this program or parts of it are used.
   8
   9 */
  10
  11 #include "expect_cf.h"
  12
  13 #include <stdio.h>
  14 #include <sys/types.h>
  15 /*#include <sys/time.h> seems to not be present on SVR3 systems */
  16 /* and it's not used anyway as far as I can tell */
  17
  18 /* AIX insists that stropts.h be included before ioctl.h, because both */
  19 /* define _IO but only ioctl.h checks first.  Oddly, they seem to be */
  20 /* defined differently! */
  21 #ifdef HAVE_STROPTS_H
  22 #  include <sys/stropts.h>
  23 #endif
  24 #include <sys/ioctl.h>
  25
  26 #ifdef HAVE_SYS_FCNTL_H
  27 #  include <sys/fcntl.h>
  28 #else
  29 #  include <fcntl.h>
  30 #endif
  31 #include <sys/file.h>
  32
  33 #include <errno.h>
  34 #include <signal.h>
  35
  36 #if defined(SIGCLD) && !defined(SIGCHLD)
  37 #define SIGCHLD SIGCLD
  38 #endif
  39
  40 #ifdef HAVE_PTYTRAP
  41 #include <sys/ptyio.h>
  42 #endif
  43
  44 #ifdef CRAY
  45 # ifndef TCSETCTTY
  46 #  if defined(HAVE_TERMIOS)
  47 #   include <termios.h>
  48 #  else
  49 #   include <termio.h>
  50 #  endif
  51 # endif
  52 #endif
  53
  54 #ifdef HAVE_UNISTD_H
  55 # include <unistd.h>
  56 #endif
  57
  58 #include <math.h>               /* for log/pow computation in send -h */
  59 #include <ctype.h>              /* all this for ispunct! */
  60
  61 #include "tclInt.h"             /* need OpenFile */
  62 /*#include <varargs.h>          tclInt.h drags in varargs.h.  Since Pyramid */
  63 /*                              objects to including varargs.h twice, just */
  64 /*                              omit this one. */
  65
  66 #include "tcl.h"
  67 #include "string.h"
  68 #include "expect.h"
  69 #include "expect_tcl.h"
  70 #include "exp_rename.h"
  71 #include "exp_prog.h"
  72 #include "exp_command.h"
  73 #include "exp_log.h"
  74 #include "exp_event.h"
  75 #include "exp_pty.h"
  76 #include "exp_tty_in.h"
  77 #ifdef TCL_DEBUGGER
  78 #include "tcldbg.h"
  79 #endif
  80
  81 /*
  82  * These constants refer to the UTF string that encodes a null character.
  83  */
  84
  85 #define NULL_STRING "\300\200" /* hex C080 */
  86 #define NULL_LENGTH 2
  87
  88 #define SPAWN_ID_VARNAME "spawn_id"
  89
  90 void exp_ecmd_remove_state_direct_and_indirect(Tcl_Interp *interp, ExpState *esPtr);
  91
  92
  93 int exp_forked = FALSE;         /* whether we are child process */
  94
  95 /* the following are use to create reserved addresses, to be used as ClientData */
  96 /* args to be used to tell commands how they were called. */
  97 /* The actual values won't be used, only the addresses, but I give them */
  98 /* values out of my irrational fear the compiler might collapse them all. */
  99 static int sendCD_error = 2;    /* called as send_error */
 100 static int sendCD_user = 3;     /* called as send_user */
 101 static int sendCD_proc = 4;     /* called as send or send_spawn */
 102 static int sendCD_tty = 6;      /* called as send_tty */
 103
 104 /*
 105  * expect_key is just a source for generating a unique stamp.  As each
 106  * expect/interact command begins, it generates a new key and marks all
 107  * the spawn ids of interest with it.  Then, if someone comes along and
 108  * marks them with yet a newer key, the old command will recognize this
 109  * reexamine the state of the spawned process.
 110  */
 111 int expect_key = 0;
 112
 113 /*
 114  * exp_configure_count is incremented whenever a spawned process is closed
 115  * or an indirect list is modified.  This forces any (stack of) expect or
 116  * interact commands to reexamine the state of the world and adjust
 117  * accordingly.
 118  */
 119 int exp_configure_count = 0;
 120
 121 #ifdef HAVE_PTYTRAP
 122 /* slaveNames provides a mapping from the pty slave names to our */
 123 /* spawn id entry.  This is needed only on HPs for stty, sigh. */
 124 static Tcl_HashTable slaveNames;
 125 #endif /* HAVE_PTYTRAP */
 126
 127 typedef struct ThreadSpecificData {
 128     /*
 129      * List of all exp channels currently open.  This is per thread and is
 130      * used to match up fd's to channels, which rarely occurs.
 131      */
 132
 133     ExpState *stdinout;
 134     ExpState *stderrX;   /* grr....stderr is a macro */
 135     ExpState *devtty;
 136     ExpState *any; /* for any_spawn_id */
 137
 138     Tcl_Channel *diagChannel; /* Unused - exp_log.c has its own. */
 139     Tcl_DString diagDString;  /* Unused */
 140     int diagEnabled;          /* Unused */
 141
 142     /* Table of structures for all Tcl channels used as -open argument
 143      * in a exp_spawn call. For refCounting of Tcl channels used by
 144      * more than one Expect channel.
 145      */
 146
 147     Tcl_HashTable origins;
 148
 149 } ThreadSpecificData;
 150
 151 static Tcl_ThreadDataKey dataKey;
 152
 153 #ifdef FULLTRAPS
 154 static void
 155 init_traps(RETSIGTYPE (*traps[])())
 156 {
 157     int i;
 158
 159     for (i=1;i<NSIG;i++) {
 160         traps[i] = SIG_ERR;
 161     }
 162 }
 163 #endif
 164
 165 /* Do not terminate format strings with \n!!! */
 166 /*VARARGS*/
 167 void
 168 exp_error TCL_VARARGS_DEF(Tcl_Interp *,arg1)
 169 /*exp_error(va_alist)*/
 170 /*va_dcl*/
 171 {
 172     Tcl_Interp *interp;
 173     char *fmt;
 174     va_list args;
 175     char buffer[2000];
 176
 177     interp = TCL_VARARGS_START(Tcl_Interp *,arg1,args);
 178     fmt = va_arg(args,char *);
 179     vsprintf(buffer,fmt,args);
 180     Tcl_SetResult(interp,buffer,TCL_VOLATILE);
 181     va_end(args);
 182 }
 183
 184 /* returns current ExpState or 0.  If 0, may be immediately followed by return TCL_ERROR. */
 185 struct ExpState *
 186 expStateCurrent(
 187     Tcl_Interp *interp,
 188     int opened,
 189     int adjust,
 190     int any)
 191 {
 192     static char *user_spawn_id = "exp0";
 193
 194     char *name = exp_get_var(interp,SPAWN_ID_VARNAME);
 195     if (!name) name = user_spawn_id;
 196
 197     return expStateFromChannelName(interp,name,opened,adjust,any,SPAWN_ID_VARNAME);
 198 }
 199
 200 ExpState *
 201 expStateCheck(
 202     Tcl_Interp *interp,
 203     ExpState *esPtr,
 204     int open,
 205     int adjust,
 206     char *msg)
 207 {
 208     if (open && !esPtr->open) {
 209         exp_error(interp,"%s: spawn id %s not open",msg,esPtr->name);
 210         return(0);
 211     }
 212     if (adjust) expAdjust(esPtr);
 213     return esPtr;
 214 }
 215
 216 ExpState *
 217 expStateFromChannelName(
 218     Tcl_Interp *interp,
 219     char *name,
 220     int open,
 221     int adjust,
 222     int any,
 223     char *msg)
 224 {
 225     ExpState *esPtr;
 226     Tcl_Channel channel;
 227     CONST char *chanName;
 228
 229     if (any) {
 230         if (0 == strcmp(name,EXP_SPAWN_ID_ANY_LIT)) {
 231             ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 232             return tsdPtr->any;
 233         }
 234     }
 235
 236     channel = Tcl_GetChannel(interp,name,(int *)0);
 237     if (!channel) return(0);
 238
 239     chanName = Tcl_GetChannelName(channel);
 240     if (!isExpChannelName(chanName)) {
 241         exp_error(interp,"%s: %s is not an expect channel - use spawn -open to convert",msg,chanName);
 242         return(0);
 243     }
 244
 245     esPtr = (ExpState *)Tcl_GetChannelInstanceData(channel);
 246
 247     return expStateCheck(interp,esPtr,open,adjust,msg);
 248 }
 249
 250 /* zero out the wait status field */
 251 static void
 252 exp_wait_zero(WAIT_STATUS_TYPE *status)
 253 {
 254     int i;
 255
 256     for (i=0;i<sizeof(WAIT_STATUS_TYPE);i++) {
 257         ((char *)status)[i] = 0;
 258     }
 259 }
 260
 261 /* called just before an ExpState entry is about to be invalidated */
 262 void
 263 exp_state_prep_for_invalidation(
 264     Tcl_Interp *interp,
 265     ExpState *esPtr)
 266 {
 267     exp_ecmd_remove_state_direct_and_indirect(interp,esPtr);
 268
 269     exp_configure_count++;
 270
 271     if (esPtr->fg_armed) {
 272         exp_event_disarm_fg(esPtr);
 273     }
 274 }
 275
 276 /*ARGSUSED*/
 277 void
 278 exp_trap_on(int master)
 279 {
 280 #ifdef HAVE_PTYTRAP
 281     if (master == -1) return;
 282     exp_slave_control(master,1);
 283 #endif /* HAVE_PTYTRAP */
 284 }
 285
 286 int
 287 exp_trap_off(char *name)
 288 {
 289 #ifdef HAVE_PTYTRAP
 290     ExpState *esPtr;
 291     int enable = 0;
 292
 293     Tcl_HashEntry *entry = Tcl_FindHashEntry(&slaveNames,name);
 294     if (!entry) {
 295         expDiagLog("exp_trap_off: no entry found for %s\n",name);
 296         return -1;
 297     }
 298
 299     esPtr = (ExpState *)Tcl_GetHashValue(entry);
 300
 301     exp_slave_control(esPtr->fdin,0);
 302
 303     return esPtr->fdin;
 304 #else
 305     return name[0];     /* pacify lint, use arg and return something */
 306 #endif
 307 }
 308
 309 static
 310 void
 311 expBusy(ExpState *esPtr)
 312 {
 313     int x = open("/dev/null",0);
 314     if (x != esPtr->fdin) {
 315         fcntl(x,F_DUPFD,esPtr->fdin);
 316         close(x);
 317     }
 318     expCloseOnExec(esPtr->fdin);
 319     esPtr->fdBusy = TRUE;
 320 }
 321
 322 int
 323 exp_close(
 324     Tcl_Interp *interp,
 325     ExpState *esPtr)
 326 {
 327     if (0 == expStateCheck(interp,esPtr,1,0,"close")) return TCL_ERROR;
 328     esPtr->open = FALSE;
 329
 330     /* restore blocking for some shells that would otherwise be */
 331     /* surprised finding stdio or /dev/tty nonblocking */
 332     (void) Tcl_SetChannelOption(interp,esPtr->channel,"-blocking","on");
 333
 334     /* Since we're closing the channel, not Tcl, we need to get Tcl's
 335        buffers flushed.  Because the channel was nonblocking, EAGAINs
 336        could leave things buffered.  They need to be synchronously
 337        written now! */
 338     Tcl_Flush(esPtr->channel);
 339
 340     /*
 341      * Ignore close errors from ptys.  Ptys on some systems return errors for
 342      * no evident reason.  Anyway, receiving an error upon pty-close doesn't
 343      * mean anything anyway as far as I know.
 344      */
 345
 346     close(esPtr->fdin);
 347     if (esPtr->fd_slave != EXP_NOFD) close(esPtr->fd_slave);
 348     if (esPtr->fdin != esPtr->fdout) close(esPtr->fdout);
 349
 350     if (esPtr->chan_orig) {
 351         esPtr->chan_orig->refCount --;
 352         if (esPtr->chan_orig->refCount <= 0) {
 353             /*
 354              * Ignore close errors from Tcl channels.  They indicate things
 355              * like broken pipelines, etc, which don't affect our
 356              * subsequent handling.
 357              */
 358
 359             ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
 360             char*               cName  = Tcl_GetChannelName(esPtr->chan_orig->channel_orig);
 361             Tcl_HashEntry*      entry  = Tcl_FindHashEntry(&tsdPtr->origins,cName);
 362             ExpOrigin*          orig   = (ExpOrigin*) Tcl_GetHashValue(entry);
 363
 364             Tcl_DeleteHashEntry(entry);
 365             ckfree ((char*)orig);
 366
 367             if (!esPtr->leaveopen) {
 368                 Tcl_VarEval(interp,"close ", cName, (char *)0);
 369             }
 370         }
 371     }
 372
 373 #ifdef HAVE_PTYTRAP
 374     if (esPtr->slave_name) {
 375         Tcl_HashEntry *entry;
 376
 377         entry = Tcl_FindHashEntry(&slaveNames,esPtr->slave_name);
 378         Tcl_DeleteHashEntry(entry);
 379
 380         ckfree(esPtr->slave_name);
 381         esPtr->slave_name = 0;
 382     }
 383 #endif
 384
 385     exp_state_prep_for_invalidation(interp,esPtr);
 386
 387     if (esPtr->user_waited) {
 388         if (esPtr->registered) {
 389             Tcl_UnregisterChannel(interp,esPtr->channel);
 390             /* at this point esPtr may have been freed so don't touch it
 391                any longer */
 392         }
 393     } else {
 394         expBusy(esPtr);
 395     }
 396
 397     return(TCL_OK);
 398 }
 399
 400 /* report whether this ExpState represents special spawn_id_any */
 401 /* we need a separate function because spawn_id_any is thread-specific */
 402 /* and can't be seen outside this file */
 403 int
 404 expStateAnyIs(ExpState *esPtr)
 405 {
 406     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 407
 408     return (esPtr == tsdPtr->any);
 409 }
 410
 411 int
 412 expDevttyIs(ExpState *esPtr)
 413 {
 414     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 415
 416     return (esPtr == tsdPtr->devtty);
 417 }
 418
 419 int
 420 expStdinoutIs(ExpState *esPtr)
 421 {
 422     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 423
 424     return (tsdPtr->stdinout == esPtr);
 425 }
 426
 427 ExpState *
 428 expStdinoutGet()
 429 {
 430     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 431
 432     return tsdPtr->stdinout;
 433 }
 434
 435 ExpState *
 436 expDevttyGet()
 437 {
 438     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 439
 440     return tsdPtr->devtty;
 441 }
 442
 443 void
 444 exp_init_spawn_id_vars(Tcl_Interp *interp)
 445 {
 446     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 447
 448     Tcl_SetVar(interp, "user_spawn_id", tsdPtr->stdinout->name,0);
 449     Tcl_SetVar(interp,"error_spawn_id",  tsdPtr->stderrX->name,0);
 450     Tcl_SetVar(interp,  "any_spawn_id",   EXP_SPAWN_ID_ANY_LIT,0);
 451
 452     /* user_spawn_id is NOT /dev/tty which could (at least in theory
 453      * anyway) be later re-opened on a different fd, while stdin might
 454      * have been redirected away from /dev/tty
 455      */
 456
 457     if (exp_dev_tty != -1) {
 458         Tcl_SetVar(interp,"tty_spawn_id",tsdPtr->devtty->name,0);
 459     }
 460 }
 461
 462 void
 463 exp_init_spawn_ids(Tcl_Interp *interp)
 464 {
 465     static ExpState any_placeholder;  /* can be shared process-wide */
 466
 467     /* note whether 0,1,2 are connected to a terminal so that if we */
 468     /* disconnect, we can shut these down.  We would really like to */
 469     /* test if 0,1,2 are our controlling tty, but I don't know any */
 470     /* way to do that portably.  Anyway, the likelihood of anyone */
 471     /* disconnecting after redirecting to a non-controlling tty is */
 472     /* virtually zero. */
 473
 474     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 475
 476     tsdPtr->stdinout = expCreateChannel(interp,0,1,isatty(0)?exp_getpid:EXP_NOPID);
 477     tsdPtr->stdinout->keepForever = 1;
 478     /* hmm, now here's an example of a output-only descriptor!! */
 479     tsdPtr->stderrX = expCreateChannel(interp,2,2,isatty(2)?exp_getpid:EXP_NOPID);
 480     tsdPtr->stderrX->keepForever = 1;
 481
 482     if (exp_dev_tty != -1) {
 483         tsdPtr->devtty = expCreateChannel(interp,exp_dev_tty,exp_dev_tty,exp_getpid);
 484         tsdPtr->devtty->keepForever = 1;
 485     }
 486
 487     /* set up a dummy channel to give us something when we need to find out if
 488        people have passed us "any_spawn_id" */
 489     tsdPtr->any = &any_placeholder;
 490
 491     /* Set up the hash table for managing the channels used via
 492      * -open.
 493      */
 494
 495     Tcl_InitHashTable (&tsdPtr->origins, TCL_STRING_KEYS);
 496 }
 497
 498 void
 499 expCloseOnExec(int fd)
 500 {
 501     (void) fcntl(fd,F_SETFD,1);
 502 }
 503
 504 #define STTY_INIT       "stty_init"
 505
 506 #if 0
 507 /*
 508  * DEBUGGING UTILITIES - DON'T DELETE */
 509 static void
 510 show_pgrp(
 511     int fd,
 512     char *string)
 513 {
 514     int pgrp;
 515
 516     fprintf(stderr,"getting pgrp for %s\n",string);
 517     if (-1 == ioctl(fd,TIOCGETPGRP,&pgrp)) perror("TIOCGETPGRP");
 518     else fprintf(stderr,"%s pgrp = %d\n",string,pgrp);
 519     if (-1 == ioctl(fd,TIOCGPGRP,&pgrp)) perror("TIOCGPGRP");
 520     else fprintf(stderr,"%s pgrp = %d\n",string,pgrp);
 521     if (-1 == tcgetpgrp(fd,pgrp)) perror("tcgetpgrp");
 522     else fprintf(stderr,"%s pgrp = %d\n",string,pgrp);
 523 }
 524
 525 static void
 526 set_pgrp(int fd)
 527 {
 528     int pgrp = getpgrp(0);
 529     if (-1 == ioctl(fd,TIOCSETPGRP,&pgrp)) perror("TIOCSETPGRP");
 530     if (-1 == ioctl(fd,TIOCSPGRP,&pgrp)) perror("TIOCSPGRP");
 531     if (-1 == tcsetpgrp(fd,pgrp)) perror("tcsetpgrp");
 532 }
 533 #endif
 534
 535 static
 536 void
 537 expSetpgrp()
 538 {
 539 #ifdef MIPS_BSD
 540     /* required on BSD side of MIPS OS <jmsellen@watdragon.waterloo.edu> */
 541 #   include <sysv/sys.s>
 542     syscall(SYS_setpgrp);
 543 #endif
 544
 545 #ifdef SETPGRP_VOID
 546     (void) setpgrp();
 547 #else
 548     (void) setpgrp(0,0);
 549 #endif
 550 }
 551
 552
 553 /*ARGSUSED*/
 554 static void
 555 set_slave_name(
 556     ExpState *esPtr,
 557     char *name)
 558 {
 559 #ifdef HAVE_PTYTRAP
 560     int newptr;
 561     Tcl_HashEntry *entry;
 562
 563     /* save slave name */
 564     esPtr->slave_name = ckalloc(strlen(exp_pty_slave_name)+1);
 565     strcpy(esPtr->slave_name,exp_pty_slave_name);
 566
 567     entry = Tcl_CreateHashEntry(&slaveNames,exp_pty_slave_name,&newptr);
 568     Tcl_SetHashValue(entry,(ClientData)esPtr);
 569 #endif /* HAVE_PTYTRAP */
 570 }
 571
 572 /* arguments are passed verbatim to execvp() */
 573 /*ARGSUSED*/
 574 static int
 575 Exp_SpawnObjCmd(
 576     ClientData clientData,
 577     Tcl_Interp *interp,
 578     int objc,
 579     Tcl_Obj *CONST objv[])              /* Argument objects. */
 580 {
 581     ExpState *esPtr = 0;
 582     int slave;
 583     int pid;
 584 #ifdef TIOCNOTTY
 585     /* tell Saber to ignore non-use of ttyfd */
 586     /*SUPPRESS 591*/
 587     int ttyfd;
 588 #endif /* TIOCNOTTY */
 589     int errorfd;        /* place to stash fileno(stderr) in child */
 590                         /* while we're setting up new stderr */
 591     int master, k;
 592     int write_master;   /* write fd of Tcl-opened files */
 593     int ttyinit = TRUE;
 594     int ttycopy = TRUE;
 595     int echo = TRUE;
 596     int console = FALSE;
 597     int pty_only = FALSE;
 598     char** argv;
 599
 600 #ifdef FULLTRAPS
 601     /* Allow user to reset signals in child */
 602     /* The following array contains indicates */
 603     /* whether sig should be DFL or IGN */
 604     /* ERR is used to indicate no initialization */
 605     RETSIGTYPE (*traps[NSIG])();
 606 #endif
 607     int ignore[NSIG];           /* if true, signal in child is ignored */
 608                                 /* if false, signal gets default behavior */
 609     int i;                      /* trusty overused temporary */
 610
 611     char *argv0 = Tcl_GetString (objv[0]);
 612     char *chanName = 0;
 613     int leaveopen = FALSE;
 614     int rc, wc;
 615     CONST char *stty_init;
 616     int slave_write_ioctls = 1;
 617     /* by default, slave will be write-ioctled this many times */
 618     int slave_opens = 3;
 619     /* by default, slave will be opened this many times */
 620     /* first comes from initial allocation */
 621     /* second comes from stty */
 622     /* third is our own signal that stty is done */
 623
 624     int sync_fds[2];
 625     int sync2_fds[2];
 626     int status_pipe[2];
 627     int child_errno;
 628     char sync_byte;
 629     int cmdIndex;
 630     Tcl_Obj* cmdObj;
 631     char* command;
 632
 633     static char* options[] = {
 634         "-console",
 635         "-ignore",
 636         "-leaveopen",
 637         "-noecho",
 638         "-nottycopy",
 639         "-nottyinit",
 640         "-open",
 641         "-pty",
 642 #ifdef FULLTRAPS
 643         "-trap",
 644 #endif
 645         NULL
 646     };
 647     enum options {
 648         SPAWN_CONSOLE
 649         ,SPAWN_IGNORE
 650         ,SPAWN_LEAVEOPEN
 651         ,SPAWN_NOECHO
 652         ,SPAWN_NOTTYCOPY
 653         ,SPAWN_NOTTYINIT
 654         ,SPAWN_OPEN
 655         ,SPAWN_PTY
 656 #ifdef FULLTRAPS
 657         ,SPAWN_TRAP
 658 #endif
 659     };
 660
 661     Tcl_Channel channel;
 662     Tcl_DString dstring;
 663     Tcl_DStringInit(&dstring);
 664
 665 #ifdef FULLTRAPS
 666     init_traps(&traps);
 667 #endif
 668     /* don't ignore any signals in child by default */
 669     for (i=1;i<NSIG;i++) {
 670         ignore[i] = FALSE;
 671     }
 672
 673     /* Check and process switches */
 674
 675     for (i=1; i<objc; i++) {
 676         char *name;
 677         int index;
 678
 679         name = Tcl_GetString(objv[i]);
 680         if (name[0] != '-') {
 681             break;
 682         }
 683         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
 684                         &index) != TCL_OK) {
 685             return TCL_ERROR;
 686         }
 687         switch ((enum options) index) {
 688             case SPAWN_NOTTYINIT:
 689                 ttyinit = FALSE;
 690                 slave_write_ioctls--;
 691                 slave_opens--;
 692                 break;
 693             case SPAWN_NOTTYCOPY:
 694                 ttycopy = FALSE;
 695                 break;
 696             case SPAWN_NOECHO:
 697                 echo = FALSE;
 698                 break;
 699             case SPAWN_CONSOLE:
 700                 console = TRUE;
 701                 break;
 702             case SPAWN_PTY:
 703                 pty_only = TRUE;
 704                 break;
 705             case SPAWN_OPEN:
 706                 i ++;
 707                 if (i >= objc) {
 708                     exp_error(interp,"usage: -open file-identifier");
 709                     return TCL_ERROR;
 710                 }
 711                 chanName = Tcl_GetString (objv[i]);
 712                 break;
 713             case SPAWN_LEAVEOPEN:
 714                 i ++;
 715                 if (i >= objc) {
 716                     exp_error(interp,"usage: -open file-identifier");
 717                     return TCL_ERROR;
 718                 }
 719                 chanName = Tcl_GetString (objv[i]);
 720                 leaveopen = TRUE;
 721                 break;
 722             case SPAWN_IGNORE: {
 723                 int sig;
 724                 i ++;
 725                 if (i >= objc) {
 726                     exp_error(interp,"usage: -ignore signal");
 727                     return TCL_ERROR;
 728                 }
 729                 sig = exp_string_to_signal(interp,Tcl_GetString (objv[i]));
 730                 if (sig == -1) {
 731                     exp_error(interp,"usage: -ignore %s: unknown signal name",Tcl_GetString (objv[i]));
 732                     return TCL_ERROR;
 733                 }
 734                 ignore[sig] = TRUE;
 735             }
 736                 break;
 737 #ifdef FULLTRAPS
 738             case SPAWN_TRAP: {
 739                 /* objv[i+1] is list of signals */
 740                 /* objv[i+2] is action */
 741
 742                 static char* actions [] = {
 743                     "SIG_DFL", "SIG_IGN", NULL
 744                 };
 745                 enum actions {
 746                     ACTION_SIGDFL, ACTION_SIGIGN;
 747                 }
 748                 int theaction;
 749
 750                 int j;
 751                 RETSIGTYPE (*sig_handler)();
 752                 int       lc;   /* number of signals in list */
 753                 Tcl_Obj** lv;   /* list of signals */
 754
 755                 if ((objc - i) < 3) {
 756                     exp_error(interp,"usage: -trap siglist SIG_DFL or SIG_IGN");
 757                     return TCL_ERROR;
 758                 }
 759
 760                 /* Check and process action */
 761
 762                 if (Tcl_GetIndexFromObj(interp, objv[i+2], actions, "action", 0,
 763                                 &theaction) != TCL_OK) {
 764                     exp_error(interp,"usage: -trap siglist SIG_DFL or SIG_IGN");
 765                     return TCL_ERROR;
 766                 }
 767                 switch ((enum actions) theaction) {
 768                     case ACTION_SIGDFL:
 769                         sig_handler = SIG_DFL;
 770                         break;
 771                     case ACTION_SIGIGN:
 772                         sig_handler = SIG_IGN;
 773                         break;
 774                 }
 775
 776                 /* Check and process list of signals */
 777
 778                 if (TCL_OK != Tcl_ListObjGetElements (inter, objv[i+1], &lc, &lv)) {
 779                     expErrorLogU(Tcl_GetStringResult(interp));
 780                     expErrorLogU("\r\n");
 781                     exp_error(interp,"usage: -trap {siglist} ...");
 782                     return TCL_ERROR;
 783                 }
 784
 785                 for (j=0;j<lc;j++) {
 786                     int sig = exp_string_to_signal(interp,Tcl_GetString (lv[j]));
 787                     if (sig == -1) {
 788                         return TCL_ERROR;
 789                     }
 790                     traps[sig] = sig_handler;
 791                 }
 792
 793                 i += 2;
 794             }
 795                 break;
 796 #endif
 797         }
 798     }
 799
 800     /* Additional checking of arguments */
 801
 802     if (chanName && (i < objc)) {
 803         exp_error(interp,"usage: -[leave]open [fileXX]");
 804         return TCL_ERROR;
 805     }
 806
 807     if (!pty_only && !chanName && (i == objc)) {
 808         exp_error(interp,"usage: spawn [spawn-args] program [program-args]");
 809         return(TCL_ERROR);
 810     }
 811
 812     cmdIndex = i;
 813     cmdObj = objv[i];
 814
 815     stty_init = exp_get_var(interp,STTY_INIT);
 816     if (stty_init) {
 817         slave_write_ioctls++;
 818         slave_opens++;
 819     }
 820
 821 /* any extraneous ioctl's that occur in slave must be accounted for
 822    when trapping, see below in child half of fork */
 823 #if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(sun) && !defined(hp9000s300)
 824     slave_write_ioctls++;
 825     slave_opens++;
 826 #endif
 827
 828     exp_pty_slave_name = 0;
 829
 830     Tcl_ReapDetachedProcs();
 831
 832     if (!chanName) {
 833         if (echo) {
 834             int c = 0;
 835             expStdoutLogU(argv0,0);
 836             for (c = 1; c < objc; c++) {
 837                 expStdoutLogU(" ",0);
 838                 expStdoutLogU(Tcl_GetString (objv[c]),0);
 839             }
 840             expStdoutLogU("\r\n",0);
 841         }
 842
 843         if (0 > (master = exp_getptymaster())) {
 844             /*
 845              * failed to allocate pty, try and figure out why
 846              * so we can suggest to user what to do about it.
 847              */
 848
 849             int testfd;
 850
 851             if (exp_pty_error) {
 852                 exp_error(interp,"%s",exp_pty_error);
 853                 return TCL_ERROR;
 854             }
 855
 856             if (expChannelCountGet() > 10) {
 857                 exp_error(interp,"The system only has a finite number of ptys and you have many of them in use.  The usual reason for this is that you forgot (or didn't know) to call \"wait\" after closing each of them.");
 858                 return TCL_ERROR;
 859             }
 860
 861             testfd = open("/",0);
 862             close(testfd);
 863
 864             if (testfd != -1) {
 865                 exp_error(interp,"The system has no more ptys.  Ask your system administrator to create more.");
 866             } else {
 867                 exp_error(interp,"- You have too many files are open.  Close some files or increase your per-process descriptor limit.");
 868             }
 869             return(TCL_ERROR);
 870         }
 871
 872         /* ordinarily channel creation takes care of close-on-exec
 873          * but because that will occur *after* fork, force close-on-exec
 874          * now in this case.
 875          */
 876         expCloseOnExec(master);
 877
 878 #define SPAWN_OUT "spawn_out"
 879         Tcl_SetVar2(interp,SPAWN_OUT,"slave,name",exp_pty_slave_name,0);
 880
 881         if (pty_only) {
 882             write_master = master;
 883         }
 884     } else {
 885         /*
 886          * process "-open $channel"
 887          */
 888         int mode, rfd, wfd;
 889         ClientData rfdc, wfdc;
 890
 891         if (echo) {
 892             expStdoutLogU(argv0,0);
 893             expStdoutLogU(" [open ...]\r\n",0);
 894         }
 895         if (!(channel = Tcl_GetChannel(interp,chanName,&mode))) {
 896             return TCL_ERROR;
 897         }
 898         if (!mode) {
 899             exp_error(interp,"channel is neither readable nor writable");
 900             return TCL_ERROR;
 901         }
 902         if (mode & TCL_READABLE) {
 903             if (TCL_ERROR == Tcl_GetChannelHandle(channel, TCL_READABLE, &rfdc)) {
 904                 return TCL_ERROR;
 905             }
 906             rfd = (int)(long) rfdc;
 907         }
 908         if (mode & TCL_WRITABLE) {
 909             if (TCL_ERROR == Tcl_GetChannelHandle(channel, TCL_WRITABLE, &wfdc)) {
 910                 return TCL_ERROR;
 911             }
 912             wfd = (int)(long) wfdc;
 913         }
 914         master = ((mode & TCL_READABLE)?rfd:wfd);
 915
 916         /* make a new copy of file descriptor */
 917         if (-1 == (write_master = master = dup(master))) {
 918             exp_error(interp,"fdopen: %s",Tcl_PosixError(interp));
 919             return TCL_ERROR;
 920         }
 921
 922         /* if writefilePtr is different, dup that too */
 923         if ((mode & TCL_READABLE) && (mode & TCL_WRITABLE) && (wfd != rfd)) {
 924             if (-1 == (write_master = dup(wfd))) {
 925                 exp_error(interp,"fdopen: %s",Tcl_PosixError(interp));
 926                 return TCL_ERROR;
 927             }
 928         }
 929
 930         /*
 931          * It would be convenient now to tell Tcl to close its
 932          * file descriptor.  Alas, if involved in a pipeline, Tcl
 933          * will be unable to complete a wait on the process.
 934          * So simply remember that we meant to close it.  We will
 935          * do so later in our own close routine.
 936          */
 937     }
 938
 939     if (chanName || pty_only) {
 940         esPtr = expCreateChannel(interp,master,write_master,EXP_NOPID);
 941
 942         if (chanName) {
 943             ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 944             Tcl_HashEntry *entry = Tcl_FindHashEntry(&tsdPtr->origins,chanName);
 945
 946             if (entry) {
 947                 esPtr->chan_orig = (ExpOrigin*) Tcl_GetHashValue(entry);
 948                 esPtr->chan_orig->refCount ++;
 949
 950             } else {
 951                 int newptr;
 952                 ExpOrigin* orig = (ExpOrigin*) ckalloc (sizeof (ExpOrigin));
 953
 954                 esPtr->chan_orig   = orig;
 955                 orig->channel_orig = channel;
 956                 orig->refCount     = 1;
 957
 958                 entry = Tcl_CreateHashEntry(&tsdPtr->origins,chanName,&newptr);
 959                 Tcl_SetHashValue(entry, (ClientData) orig);
 960             }
 961
 962             esPtr->leaveopen = leaveopen;
 963         }
 964
 965         if (exp_pty_slave_name) set_slave_name(esPtr,exp_pty_slave_name);
 966
 967         /* make it appear as if process has been waited for */
 968         esPtr->sys_waited = TRUE;
 969         exp_wait_zero(&esPtr->wait);
 970
 971         /* tell user of new spawn id */
 972         Tcl_SetVar(interp,SPAWN_ID_VARNAME,esPtr->name,0);
 973
 974         if (!chanName) {
 975             char value[20];
 976
 977             /*
 978              * open the slave side in the same process to support
 979              * the -pty flag.
 980              */
 981
 982             if (0 > (esPtr->fd_slave = exp_getptyslave(ttycopy,ttyinit,
 983                                     stty_init))) {
 984                 exp_error(interp,"open(slave pty): %s\r\n",Tcl_PosixError(interp));
 985                 return TCL_ERROR;
 986             }
 987
 988             exp_slave_control(master,1);
 989
 990             sprintf(value,"%d",esPtr->fd_slave);
 991             Tcl_SetVar2(interp,SPAWN_OUT,"slave,fd",value,0);
 992         }
 993         Tcl_SetObjResult (interp, Tcl_NewIntObj (EXP_NOPID));
 994         expDiagLog("spawn: returns {%s}\r\n",Tcl_GetStringResult(interp));
 995
 996         return TCL_OK;
 997     }
 998
 999     command = Tcl_TranslateFileName(interp,Tcl_GetString (cmdObj),&dstring);
1000     if (NULL == command) {
1001         goto parent_error;
1002     }
1003
1004     if (-1 == pipe(sync_fds)) {
1005         exp_error(interp,"too many programs spawned?  could not create pipe: %s",Tcl_PosixError(interp));
1006         goto parent_error;
1007     }
1008
1009     if (-1 == pipe(sync2_fds)) {
1010         close(sync_fds[0]);
1011         close(sync_fds[1]);
1012         exp_error(interp,"too many programs spawned?  could not create pipe: %s",Tcl_PosixError(interp));
1013         goto parent_error;
1014     }
1015
1016     if (-1 == pipe(status_pipe)) {
1017         close(sync_fds[0]);
1018         close(sync_fds[1]);
1019         close(sync2_fds[0]);
1020         close(sync2_fds[1]);
1021         exp_error(interp,"too many programs spawned?  could not create pipe: %s",Tcl_PosixError(interp));
1022         goto parent_error;
1023     }
1024
1025     if ((pid = fork()) == -1) {
1026         exp_error(interp,"fork: %s",Tcl_PosixError(interp));
1027         goto parent_error;
1028     }
1029
1030     if (pid) { /* parent */
1031         close(sync_fds[1]);
1032         close(sync2_fds[0]);
1033         close(status_pipe[1]);
1034
1035         esPtr = expCreateChannel(interp,master,master,pid);
1036
1037         if (exp_pty_slave_name) set_slave_name(esPtr,exp_pty_slave_name);
1038
1039 #ifdef CRAY
1040         setptypid(pid);
1041 #endif
1042
1043         /*
1044          * wait for slave to initialize pty before allowing
1045          * user to send to it
1046          */
1047
1048         expDiagLog("parent: waiting for sync byte\r\n");
1049         while (((rc = read(sync_fds[0],&sync_byte,1)) < 0) && (errno == EINTR)) {
1050             /* empty */;
1051         }
1052         if (rc == -1) {
1053             expErrorLogU("parent: sync byte read: ");
1054             expErrorLogU(Tcl_ErrnoMsg(errno));
1055             expErrorLogU("\r\n");
1056             exit(-1);
1057         }
1058
1059         /* turn on detection of eof */
1060         exp_slave_control(master,1);
1061
1062         /*
1063          * tell slave to go on now, now that we have initialized pty
1064          */
1065
1066         expDiagLog("parent: telling child to go ahead\r\n");
1067         wc = write(sync2_fds[1]," ",1);
1068         if (wc == -1) {
1069             expErrorLog("parent: sync byte write: %s\r\n",Tcl_ErrnoMsg(errno));
1070             exit(-1);
1071         }
1072
1073         expDiagLog("parent: now unsynchronized from child\r\n");
1074         close(sync_fds[0]);
1075         close(sync2_fds[1]);
1076
1077         /* see if child's exec worked */
1078         retry:
1079         switch (read(status_pipe[0],&child_errno,sizeof child_errno)) {
1080             case -1:
1081                 if (errno == EINTR) goto retry;
1082                 /* well it's not really the child's errno */
1083                 /* but it can be treated that way */
1084                 child_errno = errno;
1085                 break;
1086             case 0:
1087                 /* child's exec succeeded */
1088                 child_errno = 0;
1089                 break;
1090             default:
1091                 /* child's exec failed; child_errno contains exec's errno */
1092                 close(status_pipe[0]);
1093                 waitpid(pid, NULL, 0);
1094                 /* in order to get Tcl to set errorcode, we must */
1095                 /* hand set errno */
1096                 errno = child_errno;
1097                 exp_error(interp, "couldn't execute \"%s\": %s",
1098                         command,Tcl_PosixError(interp));
1099                 goto parent_error;
1100         }
1101         close(status_pipe[0]);
1102
1103         /* tell user of new spawn id */
1104         Tcl_SetVar(interp,SPAWN_ID_VARNAME,esPtr->name,0);
1105
1106         Tcl_SetObjResult (interp, Tcl_NewIntObj (pid));
1107         expDiagLog("spawn: returns {%s}\r\n",Tcl_GetStringResult(interp));
1108
1109         Tcl_DStringFree(&dstring);
1110         return(TCL_OK);
1111     }
1112
1113     /* child process - do not return from here!  all errors must exit() */
1114
1115     close(sync_fds[0]);
1116     close(sync2_fds[1]);
1117     close(status_pipe[0]);
1118     expCloseOnExec(status_pipe[1]);
1119
1120     if (exp_dev_tty != -1) {
1121         close(exp_dev_tty);
1122         exp_dev_tty = -1;
1123     }
1124
1125 #ifdef CRAY
1126     (void) close(master);
1127 #endif
1128
1129 /* ultrix (at least 4.1-2) fails to obtain controlling tty if setsid */
1130 /* is called.  setpgrp works though.  */
1131 #if defined(POSIX) && !defined(ultrix)
1132 #define DO_SETSID
1133 #endif
1134 #ifdef __convex__
1135 #define DO_SETSID
1136 #endif
1137
1138 #ifdef DO_SETSID
1139     setsid();
1140 #else
1141 #ifdef SYSV3
1142 #ifndef CRAY
1143     expSetpgrp();
1144 #endif /* CRAY */
1145 #else /* !SYSV3 */
1146     expSetpgrp();
1147
1148 /* Pyramid lacks this defn */
1149 #ifdef TIOCNOTTY
1150     ttyfd = open("/dev/tty", O_RDWR);
1151     if (ttyfd >= 0) {
1152         (void) ioctl(ttyfd, TIOCNOTTY, (char *)0);
1153         (void) close(ttyfd);
1154     }
1155 #endif /* TIOCNOTTY */
1156
1157 #endif /* SYSV3 */
1158 #endif /* DO_SETSID */
1159
1160     /* save stderr elsewhere to avoid BSD4.4 bogosity that warns */
1161     /* if stty finds dev(stderr) != dev(stdout) */
1162
1163     /* save error fd while we're setting up new one */
1164     errorfd = fcntl(2,F_DUPFD,3);
1165     /* and here is the macro to restore it */
1166 #define restore_error_fd {close(2);fcntl(errorfd,F_DUPFD,2);}
1167
1168     close(0);
1169     close(1);
1170     close(2);
1171
1172     /* since we closed fd 0, open of pty slave must return fd 0 */
1173
1174     /* since exp_getptyslave may have to run stty, (some of which work on fd */
1175     /* 0 and some of which work on 1) do the dup's inside exp_getptyslave. */
1176
1177     if (0 > (slave = exp_getptyslave(ttycopy,ttyinit,stty_init))) {
1178         restore_error_fd
1179
1180             if (exp_pty_error) {
1181                 expErrorLog("open(slave pty): %s\r\n",exp_pty_error);
1182             } else {
1183                 expErrorLog("open(slave pty): %s\r\n",Tcl_ErrnoMsg(errno));
1184             }
1185         exit(-1);
1186     }
1187     /* sanity check */
1188     if (slave != 0) {
1189         restore_error_fd
1190             expErrorLog("exp_getptyslave: slave = %d but expected 0\n",slave);
1191         exit(-1);
1192     }
1193
1194 /* The test for hpux may have to be more specific.  In particular, the */
1195 /* code should be skipped on the hp9000s300 and hp9000s720 (but there */
1196 /* is no documented define for the 720!) */
1197
1198 /*#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(sun) && !defined(hpux)*/
1199 #if defined(TIOCSCTTY) && !defined(sun) && !defined(hpux)
1200     /* 4.3+BSD way to acquire controlling terminal */
1201     /* according to Stevens - Adv. Prog..., p 642 */
1202     /* Oops, it appears that the CIBAUD is on Linux also */
1203     /* so let's try without... */
1204 #ifdef __QNX__
1205     if (tcsetct(0, getpid()) == -1) {
1206         restore_error_fd
1207             expErrorLog("failed to get controlling terminal using TIOCSCTTY");
1208         exit(-1);
1209     }
1210 #else
1211     (void) ioctl(0,TIOCSCTTY,(char *)0);
1212     /* ignore return value - on some systems, it is defined but it
1213      * fails and it doesn't seem to cause any problems.  Or maybe
1214      * it works but returns a bogus code.  Noone seems to be able
1215      * to explain this to me.  The systems are an assortment of
1216      * different linux systems (and FreeBSD 2.5), RedHat 5.2 and
1217      * Debian 2.0
1218      */
1219 #endif
1220 #endif
1221
1222 #ifdef CRAY
1223     (void) setsid();
1224     (void) ioctl(0,TCSETCTTY,0);
1225     (void) close(0);
1226     if (open("/dev/tty", O_RDWR) < 0) {
1227         restore_error_fd
1228             expErrorLog("open(/dev/tty): %s\r\n",Tcl_ErrnoMsg(errno));
1229         exit(-1);
1230     }
1231     (void) close(1);
1232     (void) close(2);
1233     (void) dup(0);
1234     (void) dup(0);
1235     setptyutmp();       /* create a utmp entry */
1236
1237     /* _CRAY2 code from Hal Peterson <hrp@cray.com>, Cray Research, Inc. */
1238 #ifdef _CRAY2
1239     /*
1240      * Interpose a process between expect and the spawned child to
1241      * keep the slave side of the pty open to allow time for expect
1242      * to read the last output.  This is a workaround for an apparent
1243      * bug in the Unicos pty driver on Cray-2's under Unicos 6.0 (at
1244      * least).
1245      */
1246     if ((pid = fork()) == -1) {
1247         restore_error_fd
1248             expErrorLog("second fork: %s\r\n",Tcl_ErrnoMsg(errno));
1249         exit(-1);
1250     }
1251
1252     if (pid) {
1253         /* Intermediate process. */
1254         int status;
1255         int timeout;
1256         char *t;
1257
1258         /* How long should we wait? */
1259         if (t = exp_get_var(interp,"pty_timeout"))
1260             timeout = atoi(t);
1261         else if (t = exp_get_var(interp,"timeout"))
1262             timeout = atoi(t)/2;
1263         else
1264             timeout = 5;
1265
1266         /* Let the spawned process run to completion. */
1267         while (wait(&status) < 0 && errno == EINTR)
1268             /* empty body */;
1269
1270         /* Wait for the pty to clear. */
1271         sleep(timeout);
1272
1273         /* Duplicate the spawned process's status. */
1274         if (WIFSIGNALED(status))
1275             kill(getpid(), WTERMSIG(status));
1276
1277         /* The kill may not have worked, but this will. */
1278         exit(WEXITSTATUS(status));
1279     }
1280 #endif /* _CRAY2 */
1281 #endif /* CRAY */
1282
1283     if (console) exp_console_set();
1284
1285 #ifdef FULLTRAPS
1286     for (i=1;i<NSIG;i++) {
1287         if (traps[i] != SIG_ERR) {
1288             signal(i,traps[i]);
1289         }
1290     }
1291 #endif /* FULLTRAPS */
1292
1293     for (i=1;i<NSIG;i++) {
1294         signal(i,ignore[i]?SIG_IGN:SIG_DFL);
1295     }
1296
1297     /*
1298      * avoid fflush of cmdfile, logfile, & diagfile since this screws up
1299      * the parents seek ptr.  There is no portable way to fclose a shared
1300      * read-stream!!!!
1301      */
1302
1303     /* (possibly multiple) masters are closed automatically due to */
1304     /* earlier fcntl(,,CLOSE_ON_EXEC); */
1305
1306     /* tell parent that we are done setting up pty */
1307     /* The actual char sent back is irrelevant. */
1308
1309     /* expDiagLog("child: telling parent that pty is initialized\r\n");*/
1310     wc = write(sync_fds[1]," ",1);
1311     if (wc == -1) {
1312         restore_error_fd
1313             expErrorLog("child: sync byte write: %s\r\n",Tcl_ErrnoMsg(errno));
1314         exit(-1);
1315     }
1316     close(sync_fds[1]);
1317
1318     /* wait for master to let us go on */
1319     while (((rc = read(sync2_fds[0],&sync_byte,1)) < 0) && (errno == EINTR)) {
1320         /* empty */;
1321     }
1322
1323     if (rc == -1) {
1324         restore_error_fd
1325             expErrorLog("child: sync byte read: %s\r\n",Tcl_ErrnoMsg(errno));
1326         exit(-1);
1327     }
1328     close(sync2_fds[0]);
1329
1330     /* expDiagLog("child: now unsynchronized from parent\r\n"); */
1331
1332     argv = (char**) ckalloc ((objc+1)*sizeof(char*));
1333     for (k=0, i=cmdIndex;i<objc;k++,i++) {
1334         argv[k] = ckalloc (1+strlen(Tcl_GetString (objv[i])));
1335         strcpy (argv[k],Tcl_GetString (objv[i]));
1336     }
1337     argv[k] = NULL;
1338
1339     execvp(command,argv);
1340
1341     for (k=0,i=cmdIndex;i<objc;k++,i++) {
1342         ckfree (argv[k]);
1343     }
1344     ckfree((char*)argv);
1345
1346     /* Alas, by now we've closed fd's to stderr, logfile and diagfile.
1347      * The only reasonable thing to do is to send back the error as part of
1348      * the program output.  This will be picked up in an expect or interact
1349      * command.
1350      */
1351
1352     /* if exec failed, communicate the reason back to the parent */
1353     write(status_pipe[1], &errno, sizeof errno);
1354     exit(-1);
1355     /*NOTREACHED*/
1356     parent_error:
1357     Tcl_DStringFree(&dstring);
1358     if (esPtr) {
1359         exp_close(interp,esPtr);
1360         waitpid(esPtr->pid,(int *)&esPtr->wait,0);
1361         if (esPtr->registered) {
1362             Tcl_UnregisterChannel(interp,esPtr->channel);
1363         }
1364     }
1365     return TCL_ERROR;
1366 }
1367
1368 /*ARGSUSED*/
1369 static int
1370 Exp_ExpPidObjCmd(
1371     ClientData clientData,
1372     Tcl_Interp *interp,
1373     int objc,
1374     Tcl_Obj *CONST objv[])              /* Argument objects. */
1375 {
1376     char *chanName = 0;
1377     ExpState *esPtr = 0;
1378
1379     static char* options[] = { "-i", NULL };
1380     enum options { PID_ID };
1381     int i;
1382
1383     for (i=1; i<objc; i++) {
1384         char *name;
1385         int index;
1386
1387         name = Tcl_GetString(objv[i]);
1388         if (name[0] != '-') {
1389             break;
1390         }
1391         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
1392                         &index) != TCL_OK) {
1393             goto usage;
1394         }
1395         switch ((enum options) index) {
1396             case PID_ID:
1397                 i++;
1398                 if (i >= objc) goto usage;
1399                 chanName = Tcl_GetString (objv[i]);
1400                 break;
1401         }
1402     }
1403
1404     if (chanName) {
1405         esPtr = expStateFromChannelName(interp,chanName,0,0,0,"exp_pid");
1406     } else {
1407         esPtr = expStateCurrent(interp,0,0,0);
1408     }
1409     if (!esPtr) return TCL_ERROR;
1410
1411     Tcl_SetObjResult (interp, Tcl_NewIntObj (esPtr->pid));
1412     return TCL_OK;
1413     usage:
1414     exp_error(interp,"usage: -i spawn_id");
1415     return TCL_ERROR;
1416 }
1417
1418 /*ARGSUSED*/
1419 static int
1420 Exp_GetpidDeprecatedObjCmd(
1421     ClientData clientData,
1422     Tcl_Interp *interp,
1423     int objc,
1424     Tcl_Obj *CONST objv[])              /* Argument objects. */
1425 {
1426     expDiagLog("getpid is deprecated, use pid\r\n");
1427     Tcl_SetObjResult (interp, Tcl_NewIntObj (getpid()));
1428     return(TCL_OK);
1429 }
1430
1431 /*ARGSUSED*/
1432 static int
1433 Exp_SleepObjCmd(
1434     ClientData clientData,
1435     Tcl_Interp *interp,
1436     int objc,
1437     Tcl_Obj *CONST objv[])              /* Argument objects. */
1438 {
1439     double s;
1440
1441     if (objc != 2) {
1442         exp_error(interp,"must have one arg: seconds");
1443         return TCL_ERROR;
1444     }
1445
1446     if (TCL_OK != Tcl_GetDoubleFromObj (interp, objv[1], &s)) {
1447         if (0 == strlen (Tcl_GetString(objv[1]))) {
1448             /* Keep undocumented acceptance of "" as 0 = no delay */
1449             return TCL_OK;
1450         }
1451         return TCL_ERROR;
1452     }
1453
1454     return exp_dsleep(interp,s);
1455 }
1456
1457 struct slow_arg {
1458     int size;
1459     double time;
1460 };
1461
1462 /* returns 0 for success, -1 for failure */
1463 static int
1464 get_slow_args(
1465     Tcl_Interp *interp,
1466     struct slow_arg *x)
1467 {
1468     int sc;             /* return from scanf */
1469     CONST char *s = exp_get_var(interp,"send_slow");
1470     if (!s) {
1471         exp_error(interp,"send -s: send_slow has no value");
1472         return(-1);
1473     }
1474     if (2 != (sc = sscanf(s,"%d %lf",&x->size,&x->time))) {
1475         exp_error(interp,"send -s: found %d value(s) in send_slow but need 2",sc);
1476         return(-1);
1477     }
1478     if (x->size <= 0) {
1479         exp_error(interp,"send -s: size (%d) in send_slow must be positive", x->size);
1480         return(-1);
1481     }
1482     if (x->time <= 0) {
1483         exp_error(interp,"send -s: time (%f) in send_slow must be larger",x->time);
1484         return(-1);
1485     }
1486     return(0);
1487 }
1488
1489 /* returns 0 for success, -1 for failure, pos. for Tcl return value */
1490 static int
1491 slow_write(
1492     Tcl_Interp *interp,
1493     ExpState *esPtr,
1494     char *buffer,
1495     int rembytes,
1496     struct slow_arg *arg)
1497 {
1498     int rc;
1499
1500     while (rembytes > 0) {
1501         int i, bytelen, charlen;
1502         char *p;
1503
1504         p = buffer;
1505         charlen = (arg->size<rembytes?arg->size:rembytes);
1506
1507         /* count out the right number of UTF8 chars */
1508         for (i=0;i<charlen;i++) {
1509             p = Tcl_UtfNext(p);
1510         }
1511         bytelen = p-buffer;
1512
1513         if (0 > expWriteChars(esPtr,buffer,bytelen)) { return(-1); }
1514         rembytes -= bytelen;
1515         buffer += bytelen;
1516
1517         /* skip sleep after last write */
1518         if (rembytes > 0) {
1519             rc = exp_dsleep(interp,arg->time);
1520             if (rc>0) return rc;
1521         }
1522     }
1523     return(0);
1524 }
1525
1526 struct human_arg {
1527     float alpha;                /* average interarrival time in seconds */
1528     float alpha_eow;    /* as above but for eow transitions */
1529     float c;            /* shape */
1530     float min, max;
1531 };
1532
1533 /* returns -1 if error, 0 if success */
1534 static int
1535 get_human_args(
1536     Tcl_Interp *interp,
1537     struct human_arg *x)
1538 {
1539     int sc;             /* return from scanf */
1540     CONST char *s = exp_get_var(interp,"send_human");
1541
1542     if (!s) {
1543         exp_error(interp,"send -h: send_human has no value");
1544         return(-1);
1545     }
1546     if (5 != (sc = sscanf(s,"%f %f %f %f %f",
1547                             &x->alpha,&x->alpha_eow,&x->c,&x->min,&x->max))) {
1548         if (sc == EOF) sc = 0;  /* make up for overloaded return */
1549         exp_error(interp,"send -h: found %d value(s) in send_human but need 5",sc);
1550         return(-1);
1551     }
1552     if (x->alpha < 0 || x->alpha_eow < 0) {
1553         exp_error(interp,"send -h: average interarrival times (%f %f) must be non-negative in send_human", x->alpha,x->alpha_eow);
1554         return(-1);
1555     }
1556     if (x->c <= 0) {
1557         exp_error(interp,"send -h: variability (%f) in send_human must be positive",x->c);
1558         return(-1);
1559     }
1560     x->c = 1/x->c;
1561
1562     if (x->min < 0) {
1563         exp_error(interp,"send -h: minimum (%f) in send_human must be non-negative",x->min);
1564         return(-1);
1565     }
1566     if (x->max < 0) {
1567         exp_error(interp,"send -h: maximum (%f) in send_human must be non-negative",x->max);
1568         return(-1);
1569     }
1570     if (x->max < x->min) {
1571         exp_error(interp,"send -h: maximum (%f) must be >= minimum (%f) in send_human",x->max,x->min);
1572         return(-1);
1573     }
1574     return(0);
1575 }
1576
1577 /* Compute random numbers from 0 to 1, for expect's send -h */
1578 /* This implementation sacrifices beauty for portability */
1579 static float
1580 unit_random()
1581 {
1582     /* current implementation is pathetic but works */
1583     /* 99991 is largest prime in my CRC - can't hurt, eh? */
1584     return((float)(1+(rand()%99991))/99991.0);
1585 }
1586
1587 void
1588 exp_init_unit_random()
1589 {
1590     srand(getpid());
1591 }
1592
1593 /* This function is my implementation of the Weibull distribution. */
1594 /* I've added a max time and an "alpha_eow" that captures the slight */
1595 /* but noticable change in human typists when hitting end-of-word */
1596 /* transitions. */
1597 /* returns 0 for success, -1 for failure, pos. for Tcl return value */
1598 static int
1599 human_write(
1600     Tcl_Interp *interp,
1601     ExpState *esPtr,
1602     char *buffer,
1603     struct human_arg *arg)
1604 {
1605     char *sp;
1606     int size;
1607     float t;
1608     float alpha;
1609     int wc;
1610     int in_word = TRUE;
1611     Tcl_UniChar ch;
1612
1613     expDiagLog("human_write: avg_arr=%f/%f  1/shape=%f  min=%f  max=%f\r\n",
1614             arg->alpha,arg->alpha_eow,arg->c,arg->min,arg->max);
1615
1616     for (sp = buffer;*sp;sp += size) {
1617         size = Tcl_UtfToUniChar(sp, &ch);
1618         /* use the end-of-word alpha at eow transitions */
1619         if (in_word && (Tcl_UniCharIsPunct(ch) || Tcl_UniCharIsSpace(ch)))
1620             alpha = arg->alpha_eow;
1621         else alpha = arg->alpha;
1622         in_word = !(Tcl_UniCharIsPunct(ch) || Tcl_UniCharIsSpace(ch));
1623
1624         t = alpha * pow(-log((double)unit_random()),arg->c);
1625
1626         /* enforce min and max times */
1627         if (t<arg->min) t = arg->min;
1628         else if (t>arg->max) t = arg->max;
1629
1630         /* skip sleep before writing first character */
1631         if (sp != buffer) {
1632             wc = exp_dsleep(interp,(double)t);
1633             if (wc > 0) return wc;
1634         }
1635
1636         wc = expWriteChars(esPtr, sp, size);
1637         if (0 > wc) return(wc);
1638     }
1639     return(0);
1640 }
1641
1642 struct exp_i *exp_i_pool = 0;
1643 struct exp_state_list *exp_state_list_pool = 0;
1644
1645 #define EXP_I_INIT_COUNT        10
1646 #define EXP_FD_INIT_COUNT       10
1647
1648 struct exp_i *
1649 exp_new_i()
1650 {
1651     int n;
1652     struct exp_i *i;
1653
1654     if (!exp_i_pool) {
1655         /* none avail, generate some new ones */
1656         exp_i_pool = i = (struct exp_i *)ckalloc(
1657             EXP_I_INIT_COUNT * sizeof(struct exp_i));
1658         for (n=0;n<EXP_I_INIT_COUNT-1;n++,i++) {
1659             i->next = i+1;
1660         }
1661         i->next = 0;
1662     }
1663
1664     /* now that we've made some, unlink one and give to user */
1665
1666     i = exp_i_pool;
1667     exp_i_pool = exp_i_pool->next;
1668     i->value = 0;
1669     i->variable = 0;
1670     i->state_list = 0;
1671     i->ecount = 0;
1672     i->next = 0;
1673     return i;
1674 }
1675
1676 struct exp_state_list *
1677 exp_new_state(ExpState *esPtr)
1678 {
1679     int n;
1680     struct exp_state_list *fd;
1681
1682     if (!exp_state_list_pool) {
1683         /* none avail, generate some new ones */
1684         exp_state_list_pool = fd = (struct exp_state_list *)ckalloc(
1685             EXP_FD_INIT_COUNT * sizeof(struct exp_state_list));
1686         for (n=0;n<EXP_FD_INIT_COUNT-1;n++,fd++) {
1687             fd->next = fd+1;
1688         }
1689         fd->next = 0;
1690     }
1691
1692     /* now that we've made some, unlink one and give to user */
1693
1694     fd = exp_state_list_pool;
1695     exp_state_list_pool = exp_state_list_pool->next;
1696     fd->esPtr = esPtr;
1697     /* fd->next is assumed to be changed by caller */
1698     return fd;
1699 }
1700
1701 void
1702 exp_free_state(struct exp_state_list *fd_first)
1703 {
1704     struct exp_state_list *fd, *penultimate;
1705
1706     if (!fd_first) return;
1707
1708     /* link entire chain back in at once by first finding last pointer */
1709     /* making that point back to pool, and then resetting pool to this */
1710
1711     /* run to end */
1712     for (fd = fd_first;fd;fd=fd->next) {
1713         penultimate = fd;
1714     }
1715     penultimate->next = exp_state_list_pool;
1716     exp_state_list_pool = fd_first;
1717 }
1718
1719 /* free a single fd */
1720 void
1721 exp_free_state_single(struct exp_state_list *fd)
1722 {
1723     fd->next = exp_state_list_pool;
1724     exp_state_list_pool = fd;
1725 }
1726
1727 void
1728 exp_free_i(
1729     Tcl_Interp *interp,
1730     struct exp_i *i,
1731     Tcl_VarTraceProc *updateproc)/* proc to invoke if indirect is written */
1732 {
1733     if (i->next) exp_free_i(interp,i->next,updateproc);
1734
1735     exp_free_state(i->state_list);
1736
1737     if (i->direct == EXP_INDIRECT) {
1738         Tcl_UntraceVar(interp,i->variable, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES,
1739                 updateproc, (ClientData)i);
1740     }
1741
1742     /* here's the long form
1743        if duration & direct     free(var)  free(val)
1744        PERM       DIR                   1
1745        PERM       INDIR     1           1
1746        TMP        DIR
1747        TMP        INDIR                 1
1748        Also if i->variable was a bogus variable name, i->value might not be
1749        set, so test i->value to protect this
1750        TMP in this case does NOT mean from the "expect" command.  Rather
1751        it means "an implicit spawn id from any expect or expect_XXX
1752        command".  In other words, there was no variable name provided.
1753     */
1754     if (i->value
1755             && (((i->direct == EXP_DIRECT) && (i->duration == EXP_PERMANENT))
1756                     || ((i->direct == EXP_INDIRECT) && (i->duration == EXP_TEMPORARY)))) {
1757         ckfree(i->value);
1758     } else if (i->duration == EXP_PERMANENT) {
1759         if (i->value) ckfree(i->value);
1760         if (i->variable) ckfree(i->variable);
1761     }
1762
1763     i->next = exp_i_pool;
1764     exp_i_pool = i;
1765 }
1766
1767 /* generate a descriptor for a "-i" flag */
1768 /* can only fail on bad direct descriptors */
1769 /* indirect descriptors always succeed */
1770 struct exp_i *
1771 exp_new_i_complex(
1772     Tcl_Interp *interp,
1773     char *arg,          /* spawn id list or a variable containing a list */
1774     int duration,               /* if we have to copy the args */
1775     /* should only need do this in expect_before/after */
1776     Tcl_VarTraceProc *updateproc)       /* proc to invoke if indirect is written */
1777 {
1778     struct exp_i *i;
1779     char **stringp;
1780
1781     i = exp_new_i();
1782
1783     i->direct = (isExpChannelName(arg) || (0 == strcmp(arg, EXP_SPAWN_ID_ANY_LIT))?EXP_DIRECT:EXP_INDIRECT);
1784 #if OBSOLETE
1785     i->direct = (isdigit(arg[0]) || (arg[0] == '-'))?EXP_DIRECT:EXP_INDIRECT;
1786 #endif
1787     if (i->direct == EXP_DIRECT) {
1788         stringp = &i->value;
1789     } else {
1790         stringp = &i->variable;
1791     }
1792
1793     i->duration = duration;
1794     if (duration == EXP_PERMANENT) {
1795         *stringp = ckalloc(strlen(arg)+1);
1796         strcpy(*stringp,arg);
1797     } else {
1798         *stringp = arg;
1799     }
1800
1801     i->state_list = 0;
1802     if (TCL_ERROR == exp_i_update(interp,i)) {
1803         exp_free_i(interp,i,(Tcl_VarTraceProc *)0);
1804         return 0;
1805     }
1806
1807     /* if indirect, ask Tcl to tell us when variable is modified */
1808
1809     if (i->direct == EXP_INDIRECT) {
1810         Tcl_TraceVar(interp, i->variable,
1811                 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES,
1812                 updateproc, (ClientData) i);
1813     }
1814
1815     return i;
1816 }
1817
1818 void
1819 exp_i_add_state(
1820     struct exp_i *i,
1821     ExpState *esPtr)
1822 {
1823     struct exp_state_list *new_state;
1824
1825     new_state = exp_new_state(esPtr);
1826     new_state->next = i->state_list;
1827     i->state_list = new_state;
1828 }
1829
1830 /* this routine assumes i->esPtr is meaningful */
1831 /* returns TCL_ERROR only on direct */
1832 /* indirects always succeed */
1833 static int
1834 exp_i_parse_states(
1835     Tcl_Interp *interp,
1836     struct exp_i *i)
1837 {
1838     struct ExpState *esPtr;
1839     char *p = i->value;
1840     int argc;
1841     char **argv;
1842     int j;
1843
1844     if (Tcl_SplitList(NULL, p, &argc, &argv) != TCL_OK) goto error;
1845
1846     for (j = 0; j < argc; j++) {
1847         esPtr = expStateFromChannelName(interp,argv[j],1,0,1,"");
1848         if (!esPtr) goto error;
1849         exp_i_add_state(i,esPtr);
1850     }
1851     ckfree((char*)argv);
1852     return TCL_OK;
1853     error:
1854     expDiagLogU("exp_i_parse_states: ");
1855     expDiagLogU(Tcl_GetStringResult(interp));
1856     return TCL_ERROR;
1857 }
1858
1859 /* updates a single exp_i struct */
1860 /* return TCL_ERROR only on direct variables */
1861 /* indirect variables always succeed */
1862 int
1863 exp_i_update(
1864     Tcl_Interp *interp,
1865     struct exp_i *i)
1866 {
1867     char *p;    /* string representation of list of spawn ids */
1868
1869     if (i->direct == EXP_INDIRECT) {
1870         p = Tcl_GetVar(interp,i->variable,TCL_GLOBAL_ONLY);
1871         if (!p) {
1872             p = "";
1873             /* *really* big variable names could blow up expDiagLog! */
1874             expDiagLog("warning: indirect variable %s undefined",i->variable);
1875         }
1876
1877         if (i->value) {
1878             if (streq(p,i->value)) return TCL_OK;
1879
1880             /* replace new value with old */
1881             ckfree(i->value);
1882         }
1883         i->value = ckalloc(strlen(p)+1);
1884         strcpy(i->value,p);
1885
1886         exp_free_state(i->state_list);
1887         i->state_list = 0;
1888     } else {
1889         /* no free, because this should only be called on */
1890         /* "direct" i's once */
1891         i->state_list = 0;
1892     }
1893     return exp_i_parse_states(interp, i);
1894 }
1895
1896 struct exp_i *
1897 exp_new_i_simple(
1898     ExpState *esPtr,
1899     int duration)               /* if we have to copy the args */
1900     /* should only need do this in expect_before/after */
1901 {
1902     struct exp_i *i;
1903
1904     i = exp_new_i();
1905
1906     i->direct = EXP_DIRECT;
1907     i->duration = duration;
1908
1909     exp_i_add_state(i,esPtr);
1910
1911     return i;
1912 }
1913
1914 /*ARGSUSED*/
1915 static int
1916 Exp_SendLogObjCmd(
1917     ClientData clientData,
1918     Tcl_Interp *interp,
1919     int objc,
1920     Tcl_Obj *CONST objv[])              /* Argument objects. */
1921 {
1922     static char* options[] = { "--", NULL };
1923     enum options { LOG_QUOTE };
1924     int i;
1925
1926     for (i=1; i<objc; i++) {
1927         char *name;
1928         int index;
1929
1930         name = Tcl_GetString(objv[i]);
1931         if (name[0] != '-') {
1932             break;
1933         }
1934         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
1935                         &index) != TCL_OK) {
1936             goto usage;
1937         }
1938         if (((enum options) index) == LOG_QUOTE) {
1939             i++;
1940             break;
1941         }
1942     }
1943
1944     if (i != (objc-1)) goto usage;
1945
1946     expLogDiagU(Tcl_GetString (objv[i]));
1947     return(TCL_OK);
1948
1949     usage:
1950     exp_error(interp,"usage: send [args] string");
1951     return TCL_ERROR;
1952 }
1953
1954
1955 /* I've rewritten this to be unbuffered.  I did this so you could shove */
1956 /* large files through "send".  If you are concerned about efficiency */
1957 /* you should quote all your send args to make them one single argument. */
1958 /*ARGSUSED*/
1959 static int
1960 Exp_SendObjCmd(
1961     ClientData clientData,
1962     Tcl_Interp *interp,
1963     int objc,
1964     Tcl_Obj *CONST objv[])
1965 {
1966     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1967     ExpState *esPtr = 0;
1968     int rc;     /* final result of this procedure */
1969     struct human_arg human_args;
1970     struct slow_arg slow_args;
1971 #define SEND_STYLE_STRING_MASK  0x07    /* mask to detect a real string arg */
1972 #define SEND_STYLE_PLAIN        0x01
1973 #define SEND_STYLE_HUMAN        0x02
1974 #define SEND_STYLE_SLOW         0x04
1975 #define SEND_STYLE_ZERO         0x10
1976 #define SEND_STYLE_BREAK        0x20
1977     int send_style = SEND_STYLE_PLAIN;
1978     int want_cooked = TRUE;
1979     char *string;               /* string to send */
1980     int len = -1;               /* length of string to send */
1981     int zeros;          /* count of how many ascii zeros to send */
1982
1983     char *chanName = 0;
1984     struct exp_state_list *state_list;
1985     struct exp_i *i;
1986     int j;
1987
1988     static char *options[] = {
1989         "-i", "-h", "-s", "-null", "-0", "-raw", "-break", "--", (char *)0
1990     };
1991     enum options {
1992         SEND_SPAWNID, SEND_HUMAN, SEND_SLOW, SEND_NULL, SEND_ZERO,
1993         SEND_RAW, SEND_BREAK, SEND_LAST
1994     };
1995
1996     for (j = 1; j < objc; j++) {
1997         char *name;
1998         int index;
1999
2000         name = Tcl_GetString(objv[j]);
2001         if (name[0] != '-') {
2002             break;
2003         }
2004         if (Tcl_GetIndexFromObj(interp, objv[j], options, "flag", 0,
2005                         &index) != TCL_OK) {
2006             return TCL_ERROR;
2007         }
2008         switch ((enum options) index) {
2009             case SEND_SPAWNID:
2010                 j++;
2011                 chanName = Tcl_GetString(objv[j]);
2012                 break;
2013
2014             case SEND_LAST:
2015                 j++;
2016                 goto getString;
2017
2018             case SEND_HUMAN:
2019                 if (-1 == get_human_args(interp,&human_args))
2020                     return(TCL_ERROR);
2021                 send_style = SEND_STYLE_HUMAN;
2022                 break;
2023
2024             case SEND_SLOW:
2025                 if (-1 == get_slow_args(interp,&slow_args))
2026                     return(TCL_ERROR);
2027                 send_style = SEND_STYLE_SLOW;
2028                 break;
2029
2030             case SEND_NULL:
2031             case SEND_ZERO:
2032                 j++;
2033                 if (j >= objc) {
2034                     zeros = 1;
2035                 } else if (Tcl_GetIntFromObj(interp, objv[j], &zeros)
2036                         != TCL_OK) {
2037                     return TCL_ERROR;
2038                 }
2039                 if (zeros < 1) return TCL_OK;
2040                 send_style = SEND_STYLE_ZERO;
2041                 string = "<zero(s)>";
2042                 break;
2043
2044             case SEND_RAW:
2045                 want_cooked = FALSE;
2046                 break;
2047
2048             case SEND_BREAK:
2049                 send_style = SEND_STYLE_BREAK;
2050                 string = "<break>";
2051                 break;
2052         }
2053     }
2054
2055     if (send_style & SEND_STYLE_STRING_MASK) {
2056         getString:
2057         if (j != objc-1) {
2058             exp_error(interp,"usage: send [args] string");
2059             return TCL_ERROR;
2060         }
2061         string = Tcl_GetStringFromObj(objv[j], &len);
2062     } else {
2063         len = strlen(string);
2064     }
2065
2066     if (clientData == &sendCD_user) esPtr = tsdPtr->stdinout;
2067     else if (clientData == &sendCD_error) esPtr = tsdPtr->stderrX;
2068     else if (clientData == &sendCD_tty) {
2069         esPtr = tsdPtr->devtty;
2070         if (!esPtr) {
2071             exp_error(interp,"send_tty: cannot send to controlling terminal in an environment when there is no controlling terminal to send to!");
2072             return TCL_ERROR;
2073         }
2074     } else if (!chanName) {
2075         /* we want to check if it is open */
2076         /* but since stdin could be closed, we have to first */
2077         /* get the fd and then convert it from 0 to 1 if necessary */
2078         if (!(esPtr = expStateCurrent(interp,0,0,0))) return(TCL_ERROR);
2079     }
2080
2081     if (esPtr) {
2082         i = exp_new_i_simple(esPtr,EXP_TEMPORARY);
2083     } else {
2084         i = exp_new_i_complex(interp,chanName,FALSE,(Tcl_VarTraceProc *)0);
2085         if (!i) return TCL_ERROR;
2086     }
2087
2088 #define send_to_stderr  (clientData == &sendCD_error)
2089 #define send_to_proc    (clientData == &sendCD_proc)
2090 #define send_to_user    ((clientData == &sendCD_user) ||        \
2091             (clientData == &sendCD_tty))
2092
2093     if (send_to_proc) {
2094         want_cooked = FALSE;
2095         expDiagLogU("send: sending \"");
2096         expDiagLogU(expPrintify(string));
2097         expDiagLogU("\" to {");
2098         /* if closing brace doesn't appear, that's because an error */
2099         /* was encountered before we could send it */
2100     } else {
2101         expLogDiagU(string);
2102     }
2103
2104     for (state_list=i->state_list;state_list;state_list=state_list->next) {
2105         esPtr = state_list->esPtr;
2106
2107         if (send_to_proc) {
2108             expDiagLog(" %s ",esPtr->name);
2109         }
2110
2111         /* check validity of each - i.e., are they open */
2112         if (0 == expStateCheck(interp,esPtr,1,0,"send")) {
2113             rc = TCL_ERROR;
2114             goto finish;
2115         }
2116         if (want_cooked) string = exp_cook(string,&len);
2117
2118         switch (send_style) {
2119             case SEND_STYLE_PLAIN:
2120                 rc = expWriteChars(esPtr,string,len);
2121                 break;
2122             case SEND_STYLE_SLOW:
2123                 rc = slow_write(interp,esPtr,string,len,&slow_args);
2124                 break;
2125             case SEND_STYLE_HUMAN:
2126                 rc = human_write(interp,esPtr,string,&human_args);
2127                 break;
2128             case SEND_STYLE_ZERO:
2129                 for (;zeros>0;zeros--) {
2130                     rc = expWriteChars(esPtr,NULL_STRING,NULL_LENGTH);
2131                 }
2132                 /* catching error on last write is sufficient */
2133                 break;
2134             case SEND_STYLE_BREAK:
2135                 exp_tty_break(interp,esPtr->fdout);
2136                 rc = 0;
2137                 break;
2138         }
2139
2140         if (rc != 0) {
2141             if (rc == -1) {
2142                 exp_error(interp,"write(spawn_id=%d): %s",esPtr->fdout,Tcl_PosixError(interp));
2143                 rc = TCL_ERROR;
2144             }
2145             goto finish;
2146         }
2147     }
2148     if (send_to_proc) expDiagLogU("}\r\n");
2149
2150     rc = TCL_OK;
2151     finish:
2152     exp_free_i(interp,i,(Tcl_VarTraceProc *)0);
2153     return rc;
2154 }
2155
2156 /*ARGSUSED*/
2157 static int
2158 Exp_LogFileObjCmd(
2159     ClientData clientData,
2160     Tcl_Interp *interp,
2161     int objc,
2162     Tcl_Obj *CONST objv[])              /* Argument objects. */
2163 {
2164     static char resultbuf[1000];
2165     char *chanName = 0;
2166     int leaveOpen = FALSE;
2167     int logAll = FALSE;
2168     int append = TRUE;
2169     char *filename = 0;
2170     int i;
2171
2172     static char* options[] = {
2173         "-a",
2174         "-info",
2175         "-leaveopen",
2176         "-noappend",
2177         "-open",
2178         NULL
2179     };
2180     enum options {
2181         LOGFILE_A,
2182         LOGFILE_INFO,
2183         LOGFILE_LEAVEOPEN,
2184         LOGFILE_NOAPPEND,
2185         LOGFILE_OPEN
2186     };
2187
2188     for (i=1; i<objc; i++) {
2189         char *name;
2190         int index;
2191
2192         name = Tcl_GetString(objv[i]);
2193         if (name[0] != '-') {
2194             break;
2195         }
2196         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
2197                         &index) != TCL_OK) {
2198             return TCL_ERROR;
2199         }
2200         switch ((enum options) index) {
2201             case LOGFILE_A:
2202                 logAll = TRUE;
2203                 break;
2204             case LOGFILE_INFO:
2205                 resultbuf[0] = '\0';
2206                 if (expLogChannelGet()) {
2207                     /* FUTURE: Use List-ops to construct a proper Tcl_Obj */
2208                     if (expLogAllGet()) strcat(resultbuf,"-a ");
2209                     if (!expLogAppendGet()) strcat(resultbuf,"-noappend ");
2210                     if (expLogFilenameGet()) {
2211                         strcat(resultbuf,expLogFilenameGet());
2212                     } else {
2213                         if (expLogLeaveOpenGet()) {
2214                             strcat(resultbuf,"-leaveopen ");
2215                         }
2216                         strcat(resultbuf,Tcl_GetChannelName(expLogChannelGet()));
2217                     }
2218                     Tcl_SetResult(interp,resultbuf,TCL_STATIC);
2219                 }
2220                 return TCL_OK;
2221             case LOGFILE_LEAVEOPEN:
2222                 i ++;
2223                 if (i >= objc) goto usage_error;
2224                 chanName = Tcl_GetString (objv[i]);
2225                 leaveOpen = TRUE;
2226                 break;
2227             case LOGFILE_NOAPPEND:
2228                 append = FALSE;
2229                 break;
2230             case LOGFILE_OPEN:
2231                 i++;
2232                 if (i >= objc) goto usage_error;
2233                 chanName = Tcl_GetString (objv[i]);
2234                 break;
2235         }
2236     }
2237
2238     if (i == (objc - 1)) {
2239         filename = Tcl_GetString (objv[i]);
2240     } else if (objc > i) {
2241         /* too many arguments */
2242         goto usage_error;
2243     }
2244
2245     if (chanName && filename) {
2246         goto usage_error;
2247     }
2248
2249     /* check if user merely wants to change logAll (-a) */
2250     if (expLogChannelGet() && (chanName || filename)) {
2251         if (filename && (0 == strcmp(filename,expLogFilenameGet()))) {
2252             expLogAllSet(logAll);
2253             return TCL_OK;
2254         } else if (chanName &&
2255                 (0 == strcmp(chanName,Tcl_GetChannelName(expLogChannelGet())))) {
2256             expLogAllSet(logAll);
2257             return TCL_OK;
2258         } else {
2259             exp_error(interp,"cannot start logging without first stopping logging");
2260             return TCL_ERROR;
2261         }
2262     }
2263
2264     if (filename) {
2265         if (TCL_ERROR == expLogChannelOpen(interp,filename,append)) {
2266             return TCL_ERROR;
2267         }
2268     } else if (chanName) {
2269         if (TCL_ERROR == expLogChannelSet(interp,chanName)) {
2270             return TCL_ERROR;
2271         }
2272     } else {
2273         expLogChannelClose(interp);
2274         if (logAll) {
2275             exp_error(interp,"cannot use -a without a file or channel");
2276             return TCL_ERROR;
2277         }
2278     }
2279     expLogAllSet(logAll);
2280     expLogLeaveOpenSet(leaveOpen);
2281
2282     return TCL_OK;
2283
2284     usage_error:
2285     exp_error(interp,"usage: log_file [-info] [-noappend] [[-a] file] [-[leave]open [open ...]]");
2286     return TCL_ERROR;
2287 }
2288
2289 /*ARGSUSED*/
2290 static int
2291 Exp_LogUserObjCmd(
2292     ClientData clientData,
2293     Tcl_Interp *interp,
2294     int objc,
2295     Tcl_Obj *CONST objv[])              /* Argument objects. */
2296 {
2297     int old_loguser = expLogUserGet();
2298
2299     if (objc == 0 || (objc == 2 && streq(Tcl_GetString (objv[1]),"-info"))) {
2300         /* do nothing */
2301     } else if (objc == 2) {
2302         int flag;
2303         if (TCL_OK != Tcl_GetBooleanFromObj (interp, objv[1], &flag)) {
2304             if (0 == strlen (Tcl_GetString(objv[1]))) {
2305                 /* Keep undocumented acceptance of "" as 0. */
2306                 flag = 0;
2307             } else {
2308                 return TCL_ERROR;
2309             }
2310         }
2311         expLogUserSet(flag);
2312     } else {
2313         exp_error(interp,"usage: [-info|1|0]");
2314     }
2315
2316     Tcl_SetObjResult (interp, Tcl_NewIntObj (old_loguser));
2317     return(TCL_OK);
2318 }
2319
2320 #ifdef TCL_DEBUGGER
2321 /*ARGSUSED*/
2322 static int
2323 Exp_DebugObjCmd(
2324     ClientData clientData,
2325     Tcl_Interp *interp,
2326     int objc,
2327     Tcl_Obj *CONST objv[])              /* Argument objects. */
2328 {
2329     int now = FALSE;    /* soon if FALSE, now if TRUE */
2330     int exp_tcl_debugger_was_available = exp_tcl_debugger_available;
2331
2332     static char* options[] = { "-now", NULL };
2333     enum options { DEBUG_NOW };
2334     int i;
2335
2336     if (objc > 3) goto usage;
2337
2338     if (objc == 1) {
2339         Tcl_SetObjResult (interp, Tcl_NewIntObj (exp_tcl_debugger_available));
2340         return TCL_OK;
2341     }
2342
2343     for (i=1; i<objc; i++) {
2344         char *name;
2345         int index;
2346
2347         name = Tcl_GetString(objv[i]);
2348         if (name[0] != '-') {
2349             break;
2350         }
2351         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
2352                         &index) != TCL_OK) {
2353             goto usage;
2354         }
2355         switch ((enum options) index) {
2356             case DEBUG_NOW:
2357                 now = TRUE;
2358                 break;
2359         }
2360     }
2361
2362     if (i == objc) {
2363         if (now) {
2364             Dbg_On(interp,1);
2365             exp_tcl_debugger_available = 1;
2366         } else {
2367             goto usage;
2368         }
2369     } else {
2370         int flag;
2371         if (TCL_OK != Tcl_GetBooleanFromObj (interp, objv[i], &flag)) {
2372             goto usage;
2373         }
2374         if (!flag) {
2375             Dbg_Off(interp);
2376             exp_tcl_debugger_available = 0;
2377         } else {
2378             Dbg_On(interp,now);
2379             exp_tcl_debugger_available = 1;
2380         }
2381     }
2382     Tcl_SetObjResult (interp, Tcl_NewBooleanObj (exp_tcl_debugger_was_available));
2383     return(TCL_OK);
2384     usage:
2385     exp_error(interp,"usage: [[-now] 1|0]");
2386     return TCL_ERROR;
2387 }
2388 #endif
2389
2390
2391 /*ARGSUSED*/
2392 static int
2393 Exp_ExpInternalObjCmd(
2394     ClientData clientData,
2395     Tcl_Interp *interp,
2396     int objc,
2397     Tcl_Obj *CONST objv[])              /* Argument objects. */
2398 {
2399     int newChannel = FALSE;
2400     Tcl_Channel oldChannel;
2401     static char resultbuf[1000];
2402     int flag, i;
2403
2404     static char* options[] = {
2405         "-f",
2406         "-info",
2407         NULL
2408     };
2409     enum options {
2410         INTERNAL_F,
2411         INTERNAL_INFO
2412     };
2413
2414     for (i=1; i<objc; i++) {
2415         char *name;
2416         int index;
2417
2418         name = Tcl_GetString(objv[i]);
2419         if (name[0] != '-') {
2420             break;
2421         }
2422         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
2423                         &index) != TCL_OK) {
2424             goto usage;
2425         }
2426         switch ((enum options) index) {
2427             case INTERNAL_INFO:
2428                 /* FUTURE: Construct a proper list Tcl_Obj here */
2429                 /* Should check that there are no arguments coming after -info */
2430
2431                 resultbuf[0] = '\0';
2432                 oldChannel = expDiagChannelGet();
2433                 if (oldChannel) {
2434                     sprintf(resultbuf,"-f %s ",expDiagFilename());
2435                 }
2436                 strcat(resultbuf,expDiagToStderrGet()?"1":"0");
2437                 Tcl_SetResult(interp,resultbuf,TCL_STATIC);
2438                 return TCL_OK;
2439             case INTERNAL_F:
2440                 i ++;
2441                 if (i >= objc) goto usage;
2442                 expDiagChannelClose(interp);
2443                 if (TCL_OK != expDiagChannelOpen(interp,Tcl_GetString (objv[i]))) {
2444                     return TCL_ERROR;
2445                 }
2446                 newChannel = TRUE;
2447                 break;
2448         }
2449     }
2450
2451     if (i >= objc) goto usage;
2452
2453     if (TCL_OK != Tcl_GetBooleanFromObj (interp, objv[i], &flag)) {
2454         goto usage;
2455     }
2456
2457     /* if no -f given, close file */
2458     if (!newChannel) {
2459         expDiagChannelClose(interp);
2460     }
2461
2462     expDiagToStderrSet(flag);
2463     return(TCL_OK);
2464     usage:
2465     exp_error(interp,"usage: [-f file] 0|1");
2466     return TCL_ERROR;
2467 }
2468
2469 char *exp_onexit_action = 0;
2470
2471 /*ARGSUSED*/
2472 static int
2473 Exp_ExitObjCmd(
2474     ClientData clientData,
2475     Tcl_Interp *interp,
2476     int objc,
2477     Tcl_Obj *CONST objv[])              /* Argument objects. */
2478 {
2479     int value = 0;
2480
2481     objc--;
2482     objv++;
2483
2484     if (objc) {
2485         if (exp_flageq(Tcl_GetString (objv[0]),"-onexit",3)) {
2486             objc--;
2487             objv++;
2488             if (objc) {
2489                 int len;
2490                 char* act = Tcl_GetStringFromObj (objv[0], &len);
2491
2492                 if (exp_onexit_action)
2493                     ckfree(exp_onexit_action);
2494
2495                 exp_onexit_action = ckalloc(len + 1);
2496                 strcpy(exp_onexit_action,act);
2497
2498             } else if (exp_onexit_action) {
2499                 Tcl_AppendResult(interp,exp_onexit_action,(char *)0);
2500             }
2501             return TCL_OK;
2502         } else if (exp_flageq(Tcl_GetString (objv[0]),"-noexit",3)) {
2503             objc--;
2504             objv++;
2505             exp_exit_handlers((ClientData)interp);
2506             return TCL_OK;
2507         }
2508     }
2509
2510     if (objc) {
2511         if (Tcl_GetIntFromObj(interp, objv[0], &value) != TCL_OK) {
2512             return TCL_ERROR;
2513         }
2514     }
2515
2516     /*
2517      * Restore previous definition of close.  Needed when expect is
2518      * dynamically loaded after close has been redefined
2519      * e.g.  the virtual file system in tclkit
2520      */
2521     Tcl_Eval(interp, "rename _close.pre_expect close");
2522     Tcl_Exit(value);
2523     /*NOTREACHED*/
2524     return TCL_ERROR;
2525 }
2526
2527 /*ARGSUSED*/
2528 static int
2529 Exp_ConfigureObjCmd(
2530     ClientData clientData,
2531     Tcl_Interp *interp,
2532     int objc,
2533     Tcl_Obj *CONST objv[])      /* Argument objects. */
2534 {
2535     /* Magic configuration stuff. */
2536     int i, opt, val;
2537
2538     static CONST84 char* options [] = {
2539         "-strictwrite", NULL
2540     };
2541     enum options {
2542         EXP_STRICTWRITE
2543     };
2544
2545     if ((objc < 3) || (objc % 2 == 0)) {
2546         Tcl_WrongNumArgs (interp, 1, objv, "-strictwrite value");
2547         return TCL_ERROR;
2548     }
2549
2550     for (i=1; i < objc; i+=2) {
2551         if (Tcl_GetIndexFromObj (interp, objv [i], options, "option",
2552                         0, &opt) != TCL_OK) {
2553             return TCL_ERROR;
2554         }
2555         switch (opt) {
2556             case EXP_STRICTWRITE:
2557                 if (Tcl_GetBooleanFromObj (interp, objv [i+1], &val) != TCL_OK) {
2558                     return TCL_ERROR;
2559                 }
2560                 exp_strict_write = val;
2561                 break;
2562         }
2563     }
2564
2565     return TCL_OK;
2566 }
2567
2568 /*ARGSUSED*/
2569 static int
2570 Exp_CloseObjCmd(
2571     ClientData clientData,
2572     Tcl_Interp *interp,
2573     int objc,
2574     Tcl_Obj *CONST objv[])      /* Argument objects. */
2575 {
2576     int onexec_flag = FALSE;    /* true if -onexec seen */
2577     int close_onexec;
2578     int slave_flag = FALSE;
2579     ExpState *esPtr = 0;
2580     char *chanName = 0;
2581     int i;
2582
2583     static char* options[] = {
2584         "-i",
2585         "-onexec",
2586         "-slave",
2587         NULL
2588     };
2589     enum options {
2590         CLOSE_ID,
2591         CLOSE_ONEXEC,
2592         CLOSE_SLAVE
2593     };
2594
2595     for (i=1; i<objc; i++) {
2596         char *name;
2597         int index;
2598
2599         name = Tcl_GetString(objv[i]);
2600         if (name[0] != '-') {
2601             break;
2602         }
2603         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
2604                         &index) != TCL_OK) {
2605             return TCL_ERROR;
2606         }
2607         switch ((enum options) index) {
2608             case CLOSE_ID:
2609                 i++;
2610                 if (i == objc) {
2611                     exp_error(interp,"usage: -i spawn_id");
2612                     return(TCL_ERROR);
2613                 }
2614                 chanName = Tcl_GetString(objv[i]);
2615                 break;
2616             case CLOSE_ONEXEC:
2617                 i++;
2618                 if (i == objc) {
2619                     on_exec_usage:
2620                     exp_error(interp,"usage: -onexec 0|1");
2621                     return(TCL_ERROR);
2622                 }
2623                 onexec_flag = TRUE;
2624                 if (TCL_OK != Tcl_GetBooleanFromObj (interp, objv[i], &close_onexec)) {
2625                     goto on_exec_usage;
2626                 }
2627                 break;
2628             case CLOSE_SLAVE:
2629                 slave_flag = TRUE;
2630                 break;
2631         }
2632     }
2633
2634     if (i < objc) {
2635         /* doesn't look like our format, it must be a Tcl-style file */
2636         /* handle.  Lucky that formats are easily distinguishable. */
2637         /* Historical note: we used "close"  long before there was a */
2638         /* Tcl builtin by the same name. */
2639
2640         Tcl_CmdInfo* close_info;
2641
2642         Tcl_ResetResult(interp);
2643
2644         close_info = (Tcl_CmdInfo*) Tcl_GetAssocData (interp, EXP_CMDINFO_CLOSE, NULL);
2645         return(close_info->objProc(close_info->objClientData,interp,objc,objv));
2646     }
2647
2648     if (chanName) {
2649         esPtr = expStateFromChannelName(interp,chanName,1,0,0,"close");
2650     } else {
2651         esPtr = expStateCurrent(interp,1,0,0);
2652     }
2653     if (!esPtr) return TCL_ERROR;
2654
2655     if (slave_flag) {
2656         if (esPtr->fd_slave != EXP_NOFD) {
2657             close(esPtr->fd_slave);
2658             esPtr->fd_slave = EXP_NOFD;
2659
2660             exp_slave_control(esPtr->fdin,1);
2661
2662             return TCL_OK;
2663         } else {
2664             exp_error(interp,"no such slave");
2665             return TCL_ERROR;
2666         }
2667     }
2668
2669     if (onexec_flag) {
2670         /* heck, don't even bother to check if fd is open or a real */
2671         /* spawn id, nothing else depends on it */
2672         fcntl(esPtr->fdin,F_SETFD,close_onexec);
2673         return TCL_OK;
2674     }
2675
2676     return(exp_close(interp,esPtr));
2677 }
2678
2679 /*ARGSUSED*/
2680 static int
2681 tcl_tracer(
2682     ClientData clientData,
2683     Tcl_Interp *interp,
2684     int level,
2685     CONST char *command,
2686     Tcl_Command cmdInfo,
2687     int objc,
2688     Tcl_Obj *CONST objv[])              /* Argument objects. */
2689 {
2690     int i;
2691
2692     /* come out on stderr, by using expErrorLog */
2693     expErrorLog("%2d",level);
2694     for (i = 0;i<level;i++) expErrorLogU("  ");
2695     expErrorLogU((char*)command);
2696     expErrorLogU("\r\n");
2697     return TCL_OK;
2698 }
2699
2700 static void
2701 tcl_tracer_del(ClientData clientData)
2702 {
2703     /* Nothing */
2704 }
2705
2706 /*ARGSUSED*/
2707 static int
2708 Exp_StraceObjCmd(
2709     ClientData clientData,
2710     Tcl_Interp *interp,
2711     int objc,
2712     Tcl_Obj *CONST objv[])              /* Argument objects. */
2713 {
2714     static int trace_level = 0;
2715     static Tcl_Trace trace_handle;
2716
2717     if (objc > 1 && streq(Tcl_GetString (objv[1]),"-info")) {
2718         Tcl_SetObjResult (interp, Tcl_NewIntObj (trace_level));
2719         return TCL_OK;
2720     }
2721
2722     if (objc != 2) {
2723         exp_error(interp,"usage: trace level");
2724         return(TCL_ERROR);
2725     }
2726     /* tracing already in effect, undo it */
2727     if (trace_level > 0) Tcl_DeleteTrace(interp,trace_handle);
2728
2729     /* get and save new trace level */
2730
2731     if (TCL_OK != Tcl_GetIntFromObj (interp, objv[1], &trace_level)) {
2732         return TCL_ERROR;
2733     }
2734
2735     if (trace_level > 0)
2736         trace_handle = Tcl_CreateObjTrace(interp, trace_level,0,
2737                 tcl_tracer,(ClientData)0,
2738                 tcl_tracer_del);
2739     return(TCL_OK);
2740 }
2741
2742 /* following defn's are stolen from tclUnix.h */
2743
2744 /*
2745  * The type of the status returned by wait varies from UNIX system
2746  * to UNIX system.  The macro below defines it:
2747  */
2748
2749 #if 0
2750 #ifndef NO_UNION_WAIT
2751 #   define WAIT_STATUS_TYPE union wait
2752 #else
2753 #   define WAIT_STATUS_TYPE int
2754 #endif
2755 #endif /* 0 */
2756
2757 /*
2758  * following definitions stolen from tclUnix.h
2759  * (should have been made public!)
2760
2761  * Supply definitions for macros to query wait status, if not already
2762  * defined in header files above.
2763  */
2764
2765 #if 0
2766 #ifndef WIFEXITED
2767 #   define WIFEXITED(stat)  (((*((int *) &(stat))) & 0xff) == 0)
2768 #endif
2769
2770 #ifndef WEXITSTATUS
2771 #   define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
2772 #endif
2773
2774 #ifndef WIFSIGNALED
2775 #   define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
2776 #endif
2777
2778 #ifndef WTERMSIG
2779 #   define WTERMSIG(stat)    ((*((int *) &(stat))) & 0x7f)
2780 #endif
2781
2782 #ifndef WIFSTOPPED
2783 #   define WIFSTOPPED(stat)  (((*((int *) &(stat))) & 0xff) == 0177)
2784 #endif
2785
2786 #ifndef WSTOPSIG
2787 #   define WSTOPSIG(stat)    (((*((int *) &(stat))) >> 8) & 0xff)
2788 #endif
2789 #endif /* 0 */
2790
2791 /* end of stolen definitions */
2792
2793 /* Describe the processes created with Expect's fork.
2794    This allows us to wait on them later.
2795
2796    This is maintained as a linked list.  As additional procs are forked,
2797    new links are added.  As procs disappear, links are marked so that we
2798    can reuse them later.
2799 */
2800
2801 struct forked_proc {
2802     int pid;
2803     WAIT_STATUS_TYPE wait_status;
2804     enum {not_in_use, wait_done, wait_not_done} link_status;
2805     struct forked_proc *next;
2806 } *forked_proc_base = 0;
2807
2808 void
2809 fork_clear_all()
2810 {
2811     struct forked_proc *f;
2812
2813     for (f=forked_proc_base;f;f=f->next) {
2814         f->link_status = not_in_use;
2815     }
2816 }
2817
2818 void
2819 fork_init(
2820     struct forked_proc *f,
2821     int pid)
2822 {
2823     f->pid = pid;
2824     f->link_status = wait_not_done;
2825 }
2826
2827 /* make an entry for a new proc */
2828 void
2829 fork_add(int pid)
2830 {
2831     struct forked_proc *f;
2832
2833     for (f=forked_proc_base;f;f=f->next) {
2834         if (f->link_status == not_in_use) break;
2835     }
2836
2837     /* add new entry to the front of the list */
2838     if (!f) {
2839         f = (struct forked_proc *)ckalloc(sizeof(struct forked_proc));
2840         f->next = forked_proc_base;
2841         forked_proc_base = f;
2842     }
2843     fork_init(f,pid);
2844 }
2845
2846 /* Provide a last-chance guess for this if not defined already */
2847 #ifndef WNOHANG
2848 #define WNOHANG WNOHANG_BACKUP_VALUE
2849 #endif
2850
2851 /* wait returns are a hodgepodge of things
2852    If wait fails, something seriously has gone wrong, for example:
2853    bogus arguments (i.e., incorrect, bogus spawn id)
2854    no children to wait on
2855    async event failed
2856    If wait succeeeds, something happened on a particular pid
2857    3rd arg is 0 if successfully reaped (if signal, additional fields supplied)
2858    3rd arg is -1 if unsuccessfully reaped (additional fields supplied)
2859 */
2860 /*ARGSUSED*/
2861 static int
2862 Exp_WaitObjCmd(
2863     ClientData clientData,
2864     Tcl_Interp *interp,
2865     int objc,
2866     Tcl_Obj *CONST objv[])              /* Argument objects. */
2867 {
2868     char *chanName = 0;
2869     struct ExpState *esPtr;
2870     struct forked_proc *fp = 0; /* handle to a pure forked proc */
2871     struct ExpState esTmp;      /* temporary memory for either f or fp */
2872     char spawn_id[20];
2873
2874     int nowait = FALSE;
2875     int result = 0;             /* 0 means child was successfully waited on */
2876                                 /* -1 means an error occurred */
2877                                 /* -2 means no eligible children to wait on */
2878
2879     static char* options[] = {
2880         "-i",
2881         "-nowait",
2882         NULL
2883     };
2884     enum options {
2885         WAIT_ID,
2886         WAIT_NOWAIT
2887     };
2888     int i;
2889
2890 #define NO_CHILD (-2)
2891
2892     for (i=1; i<objc; i++) {
2893         char *name;
2894         int index;
2895
2896         name = Tcl_GetString(objv[i]);
2897         if (name[0] != '-') {
2898             break;
2899         }
2900         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
2901                         &index) != TCL_OK) {
2902             goto usage;
2903         }
2904         switch ((enum options) index) {
2905             case WAIT_ID:
2906                 i++;
2907                 if (i >= objc) goto usage;
2908                 chanName = Tcl_GetString (objv[i]);
2909                 break;
2910             case WAIT_NOWAIT:
2911                 nowait = TRUE;
2912                 break;
2913         }
2914     }
2915
2916     if (!chanName) {
2917         esPtr = expStateCurrent(interp,0,0,1);
2918     } else {
2919         esPtr = expStateFromChannelName(interp,chanName,0,0,1,"wait");
2920     }
2921     if (!esPtr) return TCL_ERROR;
2922
2923     if (!expStateAnyIs(esPtr)) {
2924         /* check if waited on already */
2925         /* things opened by "open" or set with -nowait */
2926         /* are marked sys_waited already */
2927         if (!esPtr->sys_waited) {
2928             if (nowait) {
2929                 Tcl_Pid pid = (Tcl_Pid)(long)esPtr->pid;
2930                 /* should probably generate an error */
2931                 /* if SIGCHLD is trapped. */
2932
2933                 /* pass to Tcl, so it can do wait */
2934                 /* in background */
2935                 Tcl_DetachPids(1,&pid);
2936                 exp_wait_zero(&esPtr->wait);
2937             } else {
2938                 while (1) {
2939                     if (Tcl_AsyncReady()) {
2940                         int rc = Tcl_AsyncInvoke(interp,TCL_OK);
2941                         if (rc != TCL_OK) return(rc);
2942                     }
2943
2944                     result = waitpid(esPtr->pid,(int *)&esPtr->wait,0);
2945                     if (result == esPtr->pid) break;
2946                     if (result == -1) {
2947                         if (errno == EINTR) continue;
2948                         else break;
2949                     }
2950                 }
2951             }
2952         }
2953
2954         /*
2955          * Now have Tcl reap anything we just detached.
2956          * This also allows procs user has created with "exec &"
2957          * and and associated with an "exec &" process to be reaped.
2958          */
2959
2960         Tcl_ReapDetachedProcs();
2961         exp_rearm_sigchld(interp); /* new */
2962
2963         strcpy(spawn_id,esPtr->name);
2964     } else {
2965         /* wait for any of our own spawned processes */
2966         /* we call waitpid rather than wait to avoid running into */
2967         /* someone else's processes.  Yes, according to Ousterhout */
2968         /* this is the best way to do it. */
2969
2970         int waited_on_forked_process = 0;
2971
2972         esPtr = expWaitOnAny();
2973         if (!esPtr) {
2974             /* if it's not a spawned process, maybe its a forked process */
2975             for (fp=forked_proc_base;fp;fp=fp->next) {
2976                 if (fp->link_status == not_in_use) continue;
2977                 restart:
2978                 result = waitpid(fp->pid,(int *)&fp->wait_status,WNOHANG);
2979                 if (result == fp->pid) {
2980                     waited_on_forked_process = 1;
2981                     break;
2982                 }
2983                 if (result == 0) continue;      /* busy, try next */
2984                 if (result == -1) {
2985                     if (errno == EINTR) goto restart;
2986                     else break;
2987                 }
2988             }
2989
2990             if (waited_on_forked_process) {
2991                 /*
2992                  * The literal spawn id in the return value from wait appears
2993                  * as a -1 to indicate a forked process was waited on.
2994                  */
2995                 strcpy(spawn_id,"-1");
2996             } else {
2997                 result = NO_CHILD;      /* no children */
2998                 Tcl_ReapDetachedProcs();
2999             }
3000             exp_rearm_sigchld(interp);
3001         }
3002     }
3003
3004     /*  sigh, wedge forked_proc into an ExpState structure so we don't
3005      *  have to rewrite remaining code (too much)
3006      */
3007     if (fp) {
3008         esPtr = &esTmp;
3009         esPtr->pid = fp->pid;
3010         esPtr->wait = fp->wait_status;
3011     }
3012
3013     /* non-portable assumption that pid_t can be printed with %d */
3014
3015     if (result == -1) {
3016         Tcl_Obj* d = Tcl_NewListObj (0,NULL);
3017
3018         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (esPtr->pid));
3019         Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (spawn_id, -1));
3020         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (-1));
3021         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (errno));
3022         Tcl_ListObjAppendElement (interp, d, LITERAL ("POSIX"));
3023         Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_ErrnoId(),-1));
3024         Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_ErrnoMsg(errno),-1));
3025
3026         Tcl_SetObjResult (interp, d);
3027         result = TCL_OK;
3028     } else if (result == NO_CHILD) {
3029         exp_error(interp,"no children");
3030         return TCL_ERROR;
3031     } else {
3032         Tcl_Obj* d = Tcl_NewListObj (0,NULL);
3033         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (esPtr->pid));
3034         Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (spawn_id,-1));
3035         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (0));
3036         Tcl_ListObjAppendElement (interp, d, Tcl_NewIntObj    (WEXITSTATUS(esPtr->wait)));
3037
3038         if (WIFSIGNALED(esPtr->wait)) {
3039             Tcl_ListObjAppendElement (interp, d, LITERAL ("CHILDKILLED"));
3040             Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_SignalId ((int) (WTERMSIG(esPtr->wait))),-1));
3041             Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_SignalMsg((int) (WTERMSIG(esPtr->wait))),-1));
3042         } else if (WIFSTOPPED(esPtr->wait)) {
3043             Tcl_ListObjAppendElement (interp, d, LITERAL ("CHILDSUSP"));
3044             Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_SignalId ((int) (WSTOPSIG(esPtr->wait))),-1));
3045             Tcl_ListObjAppendElement (interp, d, Tcl_NewStringObj (Tcl_SignalMsg((int) (WSTOPSIG(esPtr->wait))),-1));
3046         }
3047
3048         Tcl_SetObjResult (interp, d);
3049     }
3050
3051     if (fp) {
3052         fp->link_status = not_in_use;
3053         return ((result == -1)?TCL_ERROR:TCL_OK);
3054     }
3055
3056     esPtr->sys_waited = TRUE;
3057     esPtr->user_waited = TRUE;
3058
3059     /* if user has already called close, forget about this entry entirely */
3060     if (!esPtr->open) {
3061         if (esPtr->registered) {
3062             Tcl_UnregisterChannel(interp,esPtr->channel);
3063         }
3064     }
3065
3066     return ((result == -1)?TCL_ERROR:TCL_OK);
3067
3068     usage:
3069     exp_error(interp,"usage: -i spawn_id");
3070     return(TCL_ERROR);
3071 }
3072
3073 /*ARGSUSED*/
3074 static int
3075 Exp_ForkObjCmd(
3076     ClientData clientData,
3077     Tcl_Interp *interp,
3078     int objc,
3079     Tcl_Obj *CONST objv[])              /* Argument objects. */
3080 {
3081     int rc;
3082     if (objc > 1) {
3083         exp_error(interp,"usage: fork");
3084         return(TCL_ERROR);
3085     }
3086
3087     rc = fork();
3088     if (rc == -1) {
3089         exp_error(interp,"fork: %s",Tcl_PosixError(interp));
3090         return TCL_ERROR;
3091     } else if (rc == 0) {
3092         /* child */
3093         exp_forked = TRUE;
3094         exp_getpid = getpid();
3095         fork_clear_all();
3096     } else {
3097         /* parent */
3098         fork_add(rc);
3099     }
3100
3101     /* both child and parent follow remainder of code */
3102     Tcl_SetObjResult (interp, Tcl_NewIntObj (rc));
3103     expDiagLog("fork: returns {%s}\r\n",Tcl_GetStringResult(interp));
3104     return(TCL_OK);
3105 }
3106
3107 /*ARGSUSED*/
3108 static int
3109 Exp_DisconnectObjCmd(
3110     ClientData clientData,
3111     Tcl_Interp *interp,
3112     int objc,
3113     Tcl_Obj *CONST objv[])              /* Argument objects. */
3114 {
3115     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
3116
3117 #ifdef TIOCNOTTY
3118     /* tell CenterLine to ignore non-use of ttyfd */
3119     /*SUPPRESS 591*/
3120     int ttyfd;
3121 #endif /* TIOCNOTTY */
3122
3123     if (objc > 1) {
3124         exp_error(interp,"usage: disconnect");
3125         return(TCL_ERROR);
3126     }
3127
3128     if (exp_disconnected) {
3129         exp_error(interp,"already disconnected");
3130         return(TCL_ERROR);
3131     }
3132     if (!exp_forked) {
3133         exp_error(interp,"can only disconnect child process");
3134         return(TCL_ERROR);
3135     }
3136     exp_disconnected = TRUE;
3137
3138     /* ignore hangup signals generated by testing ptys in getptymaster */
3139     /* and other places */
3140     signal(SIGHUP,SIG_IGN);
3141
3142     /* reopen prevents confusion between send/expect_user */
3143     /* accidentally mapping to a real spawned process after a disconnect */
3144
3145     /* if we're in a child that's about to be disconnected from the
3146        controlling tty, close and reopen 0, 1, and 2 but associated
3147        with /dev/null.  This prevents send and expect_user doing
3148        special things if newly spawned processes accidentally
3149        get allocated 0, 1, and 2.
3150     */
3151
3152     if (isatty(0)) {
3153         ExpState *stdinout = tsdPtr->stdinout;
3154         if (stdinout->valid) {
3155             exp_close(interp,stdinout);
3156             if (stdinout->registered) {
3157                 Tcl_UnregisterChannel(interp,stdinout->channel);
3158             }
3159         }
3160         open("/dev/null",0);
3161         open("/dev/null",1);
3162         /* tsdPtr->stdinout = expCreateChannel(interp,0,1,EXP_NOPID);*/
3163         /* tsdPtr->stdinout->keepForever = 1;*/
3164     }
3165     if (isatty(2)) {
3166         ExpState *devtty = tsdPtr->devtty;
3167
3168         /* reopen stderr saves error checking in error/log routines. */
3169         if (devtty->valid) {
3170             exp_close(interp,devtty);
3171             if (devtty->registered) {
3172                 Tcl_UnregisterChannel(interp,devtty->channel);
3173             }
3174         }
3175         open("/dev/null",1);
3176         /* tsdPtr->devtty = expCreateChannel(interp,2,2,EXP_NOPID);*/
3177         /* tsdPtr->devtty->keepForever = 1;*/
3178     }
3179
3180     Tcl_UnsetVar(interp,"tty_spawn_id",TCL_GLOBAL_ONLY);
3181
3182 #ifdef DO_SETSID
3183     setsid();
3184 #else
3185 #ifdef SYSV3
3186     /* put process in our own pgrp, and lose controlling terminal */
3187 #ifdef sysV88
3188     /* With setpgrp first, child ends up with closed stdio */
3189     /* according to Dave Schmitt <daves@techmpc.csg.gss.mot.com> */
3190     if (fork()) exit(0);
3191     expSetpgrp();
3192 #else
3193     expSetpgrp();
3194     /*signal(SIGHUP,SIG_IGN); moved out to above */
3195     if (fork()) exit(0);        /* first child exits (as per Stevens, */
3196     /* UNIX Network Programming, p. 79-80) */
3197     /* second child process continues as daemon */
3198 #endif
3199 #else /* !SYSV3 */
3200     expSetpgrp();
3201
3202 /* Pyramid lacks this defn */
3203 #ifdef TIOCNOTTY
3204     ttyfd = open("/dev/tty", O_RDWR);
3205     if (ttyfd >= 0) {
3206         /* zap controlling terminal if we had one */
3207         (void) ioctl(ttyfd, TIOCNOTTY, (char *)0);
3208         (void) close(ttyfd);
3209     }
3210 #endif /* TIOCNOTTY */
3211
3212 #endif /* SYSV3 */
3213 #endif /* DO_SETSID */
3214     return(TCL_OK);
3215 }
3216
3217 /*ARGSUSED*/
3218 static int
3219 Exp_OverlayObjCmd(
3220     ClientData clientData,
3221     Tcl_Interp *interp,
3222     int objc,
3223     Tcl_Obj *CONST objv[])              /* Argument objects. */
3224 {
3225     int newfd, oldfd;
3226     int dash_name = 0;
3227     char *command;
3228     int k, j;
3229     char **argv;
3230
3231     int i;
3232
3233     for (i=1;i<objc;i++) {
3234         char *name;
3235
3236         name = Tcl_GetString(objv[i]);
3237         if (name[0] != '-') {
3238             break;
3239         } else if (streq (name,"-")) {  /* - by itself */
3240             dash_name = 1;
3241             continue;
3242         }
3243
3244         if (TCL_OK != Tcl_GetIntFromObj (interp, objv[i], &newfd)) {
3245             return TCL_ERROR;
3246         }
3247         newfd = - newfd; /* Negation rids us of the effect the '-' prefix had. */
3248
3249         i ++;
3250         if (i >= objc) {
3251             exp_error(interp,"overlay -# requires additional argument");
3252             return(TCL_ERROR);
3253         }
3254         if (TCL_OK != Tcl_GetIntFromObj (interp, objv[i], &oldfd)) {
3255             return TCL_ERROR;
3256         }
3257
3258         expDiagLog("overlay: mapping fd %d to %d\r\n",oldfd,newfd);
3259         if (oldfd != newfd) (void) dup2(oldfd,newfd);
3260         else expDiagLog("warning: overlay: old fd == new fd (%d)\r\n",oldfd);
3261     }
3262
3263     if (i >= objc) {
3264         exp_error(interp,"need program name");
3265         return(TCL_ERROR);
3266     }
3267
3268     /* convert to string array for execvp.
3269      * Take only the arguments after the command name (i+1 ...). The arguments
3270      * before are arguments of overlay, not of the invoked command. The
3271      * command name is at index.
3272      */
3273
3274     argv = (char**) ckalloc ((objc+1)*sizeof(char*));
3275
3276     for (k=i+1,j=1;k<objc;k++,j++) {
3277         argv[j] = ckalloc (1+strlen(Tcl_GetString (objv[k])));
3278         strcpy (argv[j],Tcl_GetString (objv[k]));
3279     }
3280     argv[j] = NULL;
3281
3282     /* command, handle '-' */
3283     command = Tcl_GetString (objv[i]);
3284     argv[0] = ckalloc (2+strlen(command));
3285     if (dash_name) {
3286         argv [0][0] = '-';
3287         strcpy (argv[0]+1,command);
3288     } else {
3289         strcpy (argv[0],command);
3290     }
3291
3292     signal(SIGINT, SIG_DFL);
3293     signal(SIGQUIT, SIG_DFL);
3294
3295     (void) execvp(command,argv);
3296
3297     for (k=0;k<objc;k++) {
3298         ckfree (argv[k]);
3299     }
3300     ckfree ((char*)argv);
3301
3302     exp_error(interp,"execvp(%s): %s\r\n",
3303             Tcl_GetString(objv[0]),
3304             Tcl_PosixError(interp));
3305     return(TCL_ERROR);
3306 }
3307
3308 /*ARGSUSED*/
3309 int
3310 Exp_InterpreterObjCmd(
3311     ClientData clientData,
3312     Tcl_Interp *interp,
3313     int objc,
3314     Tcl_Obj *CONST objv[])              /* Argument objects. */
3315 {
3316     Tcl_Obj *eofObj = 0;
3317     int i;
3318     int index;
3319     int rc;
3320
3321     static char *options[] = {
3322         "-eof", (char *)0
3323     };
3324     enum options {
3325         FLAG_EOF
3326     };
3327
3328     for (i = 1; i < objc; i++) {
3329         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
3330                         &index) != TCL_OK) {
3331             return TCL_ERROR;
3332         }
3333         switch ((enum options) index) {
3334             case FLAG_EOF:
3335                 i++;
3336                 if (i >= objc) {
3337                     Tcl_WrongNumArgs(interp, 1, objv,"-eof cmd");
3338                     return TCL_ERROR;
3339                 }
3340                 eofObj = objv[i];
3341                 Tcl_IncrRefCount(eofObj);
3342                 break;
3343         }
3344     }
3345
3346     /* errors and ok, are caught by exp_interpreter() and discarded */
3347     /* to return TCL_OK, type "return" */
3348     rc = exp_interpreter(interp,eofObj);
3349     if (eofObj) {
3350         Tcl_DecrRefCount(eofObj);
3351     }
3352     return rc;
3353 }
3354
3355 /* this command supercede's Tcl's builtin CONTINUE command */
3356 /*ARGSUSED*/
3357 int
3358 Exp_ExpContinueObjCmd(
3359     ClientData clientData,
3360     Tcl_Interp *interp,
3361     int objc,
3362     Tcl_Obj *CONST objv[])              /* Argument objects. */
3363 {
3364     if (objc == 1) {
3365         return EXP_CONTINUE;
3366     } else if ((objc == 2) &&
3367             (0 == strcmp(Tcl_GetString (objv[1]),"-continue_timer"))) {
3368         return EXP_CONTINUE_TIMER;
3369     }
3370
3371     exp_error(interp,"usage: exp_continue [-continue_timer]\n");
3372     return(TCL_ERROR);
3373 }
3374
3375 /* most of this is directly from Tcl's definition for return */
3376 /*ARGSUSED*/
3377 int
3378 Exp_InterReturnObjCmd(
3379     ClientData clientData,
3380     Tcl_Interp *interp,
3381     int objc,
3382     Tcl_Obj *CONST objv[])
3383 {
3384     /* let Tcl's return command worry about args */
3385     /* if successful (i.e., TCL_RETURN is returned) */
3386     /* modify the result, so that we will handle it specially */
3387
3388     Tcl_CmdInfo* return_info = (Tcl_CmdInfo*)
3389         Tcl_GetAssocData (interp, EXP_CMDINFO_RETURN, NULL);
3390
3391     int result = return_info->objProc(return_info->objClientData,interp,objc,objv);
3392     if (result == TCL_RETURN)
3393         result = EXP_TCL_RETURN;
3394     return result;
3395 }
3396
3397 /*ARGSUSED*/
3398 int
3399 Exp_OpenObjCmd(
3400     ClientData clientData,
3401     Tcl_Interp *interp,
3402     int objc,
3403     Tcl_Obj *CONST objv[])              /* Argument objects. */
3404 {
3405     ExpState *esPtr;
3406     char *chanName = 0;
3407     int newfd;
3408     int leaveopen = FALSE;
3409     Tcl_Channel channel;
3410
3411     static char* options[] = {
3412         "-i",
3413         "-leaveopen",
3414         NULL
3415     };
3416     enum options {
3417         OPEN_ID,
3418         OPEN_LEAVEOPEN
3419     };
3420     int i;
3421
3422     for (i=1; i<objc; i++) {
3423         char *name;
3424         int index;
3425
3426         name = Tcl_GetString(objv[i]);
3427         if (name[0] != '-') {
3428             break;
3429         }
3430         if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
3431                         &index) != TCL_OK) {
3432             goto usage;
3433         }
3434         switch ((enum options) index) {
3435             case OPEN_ID:
3436                 i++;
3437                 if (i >= objc) goto usage;
3438                 chanName = Tcl_GetString (objv[i]);
3439                 break;
3440             case OPEN_LEAVEOPEN:
3441                 leaveopen = TRUE;
3442                 break;
3443         }
3444     }
3445
3446     if (!chanName) {
3447         esPtr = expStateCurrent(interp,1,0,0);
3448     } else {
3449         esPtr = expStateFromChannelName(interp,chanName,1,0,0,"exp_open");
3450     }
3451     if (!esPtr) return TCL_ERROR;
3452
3453     /* make a new copy of file descriptor */
3454     if (-1 == (newfd = dup(esPtr->fdin))) {
3455         exp_error(interp,"dup: %s",Tcl_PosixError(interp));
3456         return TCL_ERROR;
3457     }
3458
3459     if (!leaveopen) {
3460         /* remove from Expect's memory in anticipation of passing to Tcl */
3461         if (esPtr->pid != EXP_NOPID) {
3462             Tcl_Pid pid = (Tcl_Pid)(long)esPtr->pid;
3463             Tcl_DetachPids(1,&pid);
3464             esPtr->pid = EXP_NOPID;
3465             esPtr->sys_waited = esPtr->user_waited = TRUE;
3466         }
3467         exp_close(interp,esPtr);
3468     }
3469
3470     /*
3471      * Tcl's MakeFileChannel only allows us to pass a single file descriptor
3472      * but that shouldn't be a problem in practice since all of the channels
3473      * that Expect generates only have one fd.  Of course, this code won't
3474      * work if someone creates a pipeline, then passes it to spawn, and then
3475      * again to exp_open.  For that to work, Tcl would need a new API.
3476      * Oh, and we're also being rather cavalier with the permissions here,
3477      * but they're likely to be right for the same reasons.
3478      */
3479     channel = Tcl_MakeFileChannel((ClientData)(long)newfd,TCL_READABLE|TCL_WRITABLE);
3480     Tcl_RegisterChannel(interp, channel);
3481     Tcl_AppendResult(interp, Tcl_GetChannelName(channel), (char *) NULL);
3482     return TCL_OK;
3483
3484     usage:
3485     exp_error(interp,"usage: -i spawn_id");
3486     return TCL_ERROR;
3487 }
3488
3489 /* return 1 if a string is substring of a flag */
3490 /* this version is the code used by the macro that everyone calls */
3491 int
3492 exp_flageq_code(
3493     char *flag,
3494     char *string,
3495     int minlen)         /* at least this many chars must match */
3496 {
3497     for (;*flag;flag++,string++,minlen--) {
3498         if (*string == '\0') break;
3499         if (*string != *flag) return 0;
3500     }
3501     if (*string == '\0' && minlen <= 0) return 1;
3502     return 0;
3503 }
3504
3505 void
3506 exp_create_commands(interp,c)
3507     Tcl_Interp *interp;
3508     struct exp_cmd_data *c;
3509 {
3510     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
3511     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
3512     char cmdnamebuf[80];
3513
3514     for (;c->name;c++) {
3515         /* if already defined, don't redefine */
3516         if ((c->flags & EXP_REDEFINE) ||
3517                 !(Tcl_FindHashEntry(&globalNsPtr->cmdTable,c->name) ||
3518                         Tcl_FindHashEntry(&currNsPtr->cmdTable,c->name))) {
3519             if (c->objproc)
3520                 Tcl_CreateObjCommand(interp,c->name,
3521                         c->objproc,c->data,exp_deleteObjProc);
3522             else
3523                 Tcl_CreateCommand(interp,c->name,c->proc,
3524                         c->data,exp_deleteProc);
3525         }
3526         if (!(c->name[0] == 'e' &&
3527                         c->name[1] == 'x' &&
3528                         c->name[2] == 'p')
3529                 && !(c->flags & EXP_NOPREFIX)) {
3530             sprintf(cmdnamebuf,"exp_%s",c->name);
3531             if (c->objproc)
3532                 Tcl_CreateObjCommand(interp,cmdnamebuf,c->objproc,c->data,
3533                         exp_deleteObjProc);
3534             else
3535                 Tcl_CreateCommand(interp,cmdnamebuf,c->proc,
3536                         c->data,exp_deleteProc);
3537         }
3538     }
3539 }
3540
3541 static struct exp_cmd_data cmd_data[]  = {
3542     {"close",        Exp_CloseObjCmd,   0,      (ClientData)0,  EXP_REDEFINE},
3543 #ifdef TCL_DEBUGGER
3544     {"debug",        Exp_DebugObjCmd,       0,  (ClientData)0,  0},
3545 #endif
3546     {"exp_internal", Exp_ExpInternalObjCmd, 0,  (ClientData)0,  0},
3547     {"disconnect",   Exp_DisconnectObjCmd,  0,  (ClientData)0,  0},
3548     {"exit",         Exp_ExitObjCmd,        0,  (ClientData)0,  EXP_REDEFINE},
3549     {"exp_continue", Exp_ExpContinueObjCmd, 0,  (ClientData)0,  0},
3550     {"fork",         Exp_ForkObjCmd,        0,  (ClientData)0,  0},
3551     {"exp_pid",      Exp_ExpPidObjCmd,      0,  (ClientData)0,  0},
3552     {"getpid",       Exp_GetpidDeprecatedObjCmd, 0,     (ClientData)0,  0},
3553     {"interpreter",  Exp_InterpreterObjCmd, 0,  (ClientData)0,  0},
3554     {"log_file",     Exp_LogFileObjCmd,     0,  (ClientData)0,  0},
3555     {"log_user",     Exp_LogUserObjCmd,     0,  (ClientData)0,  0},
3556     {"exp_open",     Exp_OpenObjCmd,        0,  (ClientData)0,  0},
3557     {"overlay",      Exp_OverlayObjCmd,     0,  (ClientData)0,  0},
3558     {"inter_return", Exp_InterReturnObjCmd, 0,  (ClientData)0,  0},
3559     {"send",         Exp_SendObjCmd,        0,  (ClientData)&sendCD_proc,0},
3560     {"send_error",   Exp_SendObjCmd,        0,  (ClientData)&sendCD_error,0},
3561     {"send_log",     Exp_SendLogObjCmd,     0,  (ClientData)0,  0},
3562     {"send_tty",     Exp_SendObjCmd,        0,  (ClientData)&sendCD_tty,0},
3563     {"send_user",    Exp_SendObjCmd,        0,  (ClientData)&sendCD_user,0},
3564     {"sleep",        Exp_SleepObjCmd,       0,  (ClientData)0,  0},
3565     {"spawn",        Exp_SpawnObjCmd,       0,  (ClientData)0,  0},
3566     {"strace",       Exp_StraceObjCmd,      0,  (ClientData)0,  0},
3567     {"wait",         Exp_WaitObjCmd,        0,  (ClientData)0,  0},
3568     {"exp_configure",Exp_ConfigureObjCmd,   0,  (ClientData)0,  0},
3569     {0}};
3570
3571 void
3572 exp_init_most_cmds(Tcl_Interp *interp)
3573 {
3574     exp_create_commands(interp,cmd_data);
3575
3576 #ifdef HAVE_PTYTRAP
3577     Tcl_InitHashTable(&slaveNames,TCL_STRING_KEYS);
3578 #endif /* HAVE_PTYTRAP */
3579 }
3580 \f
3581 /*
3582  * Local Variables:
3583  * mode: c
3584  * c-basic-offset: 4
3585  * fill-column: 78
3586  * End:
3587  */