~ubuntu-branches/ubuntu/vivid/gcl/vivid

/*
 * tkXshell.c
 *
 * Version of Tk main that is modified to build a wish shell with the Extended
 * Tcl command set and libraries.  This makes it easier to use a different
 * main.
 *-----------------------------------------------------------------------------
 * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
 * Mark Diekhans make no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without express or
 * implied warranty.
 *-----------------------------------------------------------------------------
 * $Id$
 *-----------------------------------------------------------------------------
 */

/* 
 * main.c --
 *
 *	This file contains the main program for "wish", a windowing
 *	shell based on Tk and Tcl.  It also provides a template that
 *	can be used as the basis for main programs for other Tk
 *	applications.
 *
 * Copyright (c) 1990-1993 The Regents of the University of California.
 * All rights reserved.
 *
 * Permission is hereby granted, without written agreement and without
 * license or royalty fees, to use, copy, modify, and distribute this
 * software and its documentation for any purpose, provided that the
 * above copyright notice and the following two paragraphs appear in
 * all copies of this software.
 * 
 * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
 * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
 * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
 * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
 * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
 * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 */

#ifdef __cplusplus
#    include "tcl++.h"
#    include <unistd.h>
#else
#    include "tclExtend.h"
#endif

#include "tk.h"

/*-------------------------------------------------------------------*/
#include <unistd.h>
#include <sys/types.h>
#include <signal.h>

int sock_write( int connection, const char *text, int length );
int sock_read( int connection, char *buffer, int max_len );

extern int hdl;
extern pid_t parent;
/*-------------------------------------------------------------------*/

/*
 * Declarations for various library procedures and variables (don't want
 * to include tkInt.h or tkConfig.h here, because people might copy this
 * file out of the Tk source directory to make their own modified versions).
 */

extern void		exit _ANSI_ARGS_((int status));
extern int		isatty _ANSI_ARGS_((int fd));
/*
extern int		read _ANSI_ARGS_((int fd, char *buf, size_t size));
*/
extern char *		strrchr _ANSI_ARGS_((CONST char *string, int c));

/*
 * Global variables used by the main program:
 */

static Tk_Window mainWindow;	/* The main window for the application.  If
				 * NULL then the application no longer
				 * exists. */
static Tcl_Interp *interp;	/* Interpreter for this application. */
char *tcl_RcFileName ;  	/* Name of a user-specific startup script
				 * to source if the application is being run
				 * interactively (e.g. "~/.wishrc").  Set
				 * by Tcl_AppInit.  NULL means don't source
				 * anything ever. */
static Tcl_DString command;	/* Used to assemble lines of terminal input
				 * into Tcl commands. */
static int gotPartial = 0;      /* Partial command in buffer. */
static int tty;			/* Non-zero means standard input is a
				 * terminal-like device.  Zero means it's
				 * a file. */
static char exitCmd[] = "exit";
static char errorExitCmd[] = "exit 1";

/*
 * Command-line options:
 */

static int synchronize = 0;
static char *fileName = NULL;
static char *name = NULL;
static char *display = NULL;
static char *geometry = NULL;

static Tk_ArgvInfo argTable[] = {
    {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
	"File from which to read commands"},
    {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
	"Initial geometry for window"},
    {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
	"Display to use"},
    {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
	"Name to use for application"},
    {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
	"Use synchronous mode for display server"},
    {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
	(char *) NULL}
};

/*
 * Forward declarations for procedures defined later in this file:
 */

static void		StdinProc _ANSI_ARGS_((ClientData clientData,
			    int mask));
static void		SignalProc _ANSI_ARGS_((int signalNum));

/*
 *----------------------------------------------------------------------
 *
 * TkX_Wish --
 *
 *	Main program for Wish.
 *
 * Results:
 *	None. This procedure never returns (it exits the process when
 *	it's done
 *
 * Side effects:
 *	This procedure initializes the wish world and then starts
 *	interpreting commands;  almost anything could happen, depending
 *	on the script being interpreted.
 *
 *----------------------------------------------------------------------
 */

void
TkX_Wish (argc, argv)
    int argc;				/* Number of arguments. */
    char **argv;			/* Array of argument strings. */
{
    char *args, *p, *msg;
    char buf[20];
    int code;

    interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
    Tcl_InitMemory(interp);
#endif

    /*
     * Parse command-line arguments.
     */

    if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
	    != TCL_OK) {
	fprintf(stderr, "%s\n", interp->result);
	exit(1);
    }
    if (name == NULL) {
	if (fileName != NULL) {
	    p = fileName;
	} else {
	    p = argv[0];
	}
	name = strrchr(p, '/');
	if (name != NULL) {
	    name++;
	} else {
	    name = p;
	}
    }

    /*
     * If a display was specified, put it into the DISPLAY
     * environment variable so that it will be available for
     * any sub-processes created by us.
     */

    if (display != NULL) {
	Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
    }

    /*
     * Set the "tcl_interactive" variable.
     */
    tty = isatty(hdl);
    Tcl_SetVar(interp, "tcl_interactive",
 	    ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
 
    tty = isatty(hdl);

    /*
     * Initialize the Tk application.
     */

    mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk");
    if (mainWindow == NULL) {
	fprintf(stderr, "%s\n", interp->result);
	exit(1);
    }
    Tk_SetClass(mainWindow, "Tk");
    if (synchronize) {
	XSynchronize(Tk_Display(mainWindow), True);
    }
    Tk_GeometryRequest(mainWindow, 200, 200);

    /*
     * Make command-line arguments available in the Tcl variables "argc"
     * and "argv".  Also set the "geometry" variable from the geometry
     * specified on the command line.
     */

    args = Tcl_Merge(argc-1, argv+1);
    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
    ckfree(args);
    sprintf(buf, "%d", argc-1);
    Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
	    TCL_GLOBAL_ONLY);
    if (geometry != NULL) {
	Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
    }

    /*
     * Invoke application-specific initialization.
     */

    if (Tcl_AppInit(interp) != TCL_OK) {
	TclX_ErrorExit (interp, 255);
    }

    /*
     * Set the geometry of the main window, if requested.
     */

    if (geometry != NULL) {
	code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
	if (code != TCL_OK) {
	    fprintf(stderr, "%s\n", interp->result);
	}
    }

    /*
     * Invoke the script specified on the command line, if any.
     */

    if (fileName != NULL) {
	code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
	if (code != TCL_OK) {
	    goto error;
	}
	tty = 0;
    } else {
        TclX_EvalRCFile (interp);

	/*
	 * Commands will come from standard input.  Set up a handler
	 * to receive those characters and print a prompt if the input
	 * device is a terminal.
	 */
        tclErrorSignalProc = SignalProc;
	Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0);
	if (tty) {
	    TclX_OutputPrompt (interp, 1);
	}
    }
    tclSignalBackgroundError = Tk_BackgroundError;

    fflush(stdout);
    Tcl_DStringInit(&command);

    /*
     * Loop infinitely, waiting for commands to execute.  When there
     * are no windows left, Tk_MainLoop returns and we exit.
     */

    Tk_MainLoop();

    /*
     * Don't exit directly, but rather invoke the Tcl "exit" command.
     * This gives the application the opportunity to redefine "exit"
     * to do additional cleanup.
     */

    Tcl_GlobalEval(interp, exitCmd);
    exit(1);

error:
    msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
    if (msg == NULL) {
	msg = interp->result;
    }
    fprintf(stderr, "%s\n", msg);
    Tcl_GlobalEval(interp, errorExitCmd);
    exit (1);
}

/*
 *----------------------------------------------------------------------
 *
 * SignalProc --
 *
 *	Function called on a signal generating an error to clear the stdin
 *   	buffer.
 *----------------------------------------------------------------------
 */

static void
SignalProc (signalNum)
    int  signalNum;
{
    tclGotErrorSignal = 0;
    Tcl_DStringFree (&command);
    gotPartial = 0;
    if (tty) {
        fputc ('\n', stdout);
        TclX_OutputPrompt (interp, !gotPartial);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * StdinProc --
 *
 *	This procedure is invoked by the event dispatcher whenever
 *	standard input becomes readable.  It grabs the next line of
 *	input characters, adds them to a command being assembled, and
 *	executes the command if it's complete.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Could be almost arbitrary, depending on the command that's
 *	typed.
 *
 *----------------------------------------------------------------------
 */

#define BUFFER_SIZE 4000

static void
StdinProc(clientData, mask)
    ClientData clientData;		/* Not used. */
    int mask;				/* Not used. */
{
  char input[BUFFER_SIZE+1];
  char *cmd;
  int code, count;
  
  count = read(hdl, input, BUFFER_SIZE);
  if (count <= 0)
    {
      if (!gotPartial)
	{
	  if (tty)
	    {
	      Tcl_VarEval(interp, "exit", (char *) NULL);
	      exit(1);
	    }
	  else 
	    {
	      Tk_DeleteFileHandler(hdl);
	    }
	  return;
	}
      else
	{
	  count = 0;
	}
    }
  cmd = Tcl_DStringAppend(&command, input, count);

  fprintf(stderr, "TK command : %s\n", cmd);
  fflush(stderr);

  if (count != 0)
    {
      if ((input[count-1] != '\n') && (input[count-1] != ';'))
	{
	  gotPartial = 1;
	  goto exitPoint;
	}
      if (!Tcl_CommandComplete(cmd))
	{
	  fprintf(stderr, "Partial command\n", cmd);
	  fflush(stderr);
	  
	  gotPartial = 1;
	  goto exitPoint;
	}
    }
  gotPartial = 0;

/*
* Disable the stdin file handler;  otherwise if the command
* re-enters the event loop we might process commands from
* stdin before the current command is finished.  Among other
* things, this will trash the text of the command being evaluated.
*/

  Tk_CreateFileHandler(hdl, 0, StdinProc, (ClientData) 0);
  code = Tcl_RecordAndEval(interp, cmd, 0);
  Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0);
  if (tty)
    TclX_PrintResult (interp, code, cmd);
  else
    {
      char buf[1024];
      sprintf(buf, "%d %s", code, interp->result);
      sock_write(hdl, buf, strlen(buf));
      kill(parent, SIGUSR1);
    }
  Tcl_DStringFree(&command);
  
 exitPoint:
  if (tty)
    {
      TclX_OutputPrompt (interp, !gotPartial);
    }
}