text: /*
   * tkMacOSXSend.c --
   *
   *	This file provides procedures that implement the "send" command,
   *	allowing commands to be passed from interpreter to interpreter. This
   *	current implementation for the Mac has most functionality stubed out.
   *
   *	The current plan, which we have not had time to implement, is for the
   *	first Wish app to create a gestalt of type 'WIsH'. This gestalt will
   *	point to a table, in system memory, of Tk apps. Each Tk app, when it
   *	starts up, will register their name, and process ID, in this table.
   *	This will allow us to implement "tk appname".
   *
   *	Then the send command will look up the process id of the target app in
   *	this table, and send an AppleEvent to that process. The AppleEvent
   *	handler is much like the do script handler, except that you have to
   *	specify the name of the tk app as well, since there may be many
   *	interps in one wish app, and you need to send it to the right one.
   *
   *	Implementing this has been on our list of things to do, but what with
   *	the demise of Tcl at Sun, and the lack of resources at Scriptics it
   *	may not get done for awhile. So this sketch is offered for the brave
   *	to attempt if they need the functionality...
   *
   * Copyright (c) 1989-1994 The Regents of the University of California.
   * Copyright (c) 1994-1998 Sun Microsystems, Inc.
   * Copyright 2001, Apple Computer, Inc.
   * Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net>
   *
   * See the file "license.terms" for information on usage and redistribution of
   * this file, and for a DISCLAIMER OF ALL WARRANTIES.
   */
  
  #include "tkMacOSXInt.h"
  
  /*
   * The following structure is used to keep track of the interpreters
   * registered by this process.
   */
  
  typedef struct RegisteredInterp {
      char *name;			/* Interpreter's name (malloc-ed). */
      Tcl_Interp *interp;		/* Interpreter associated with name. */
      struct RegisteredInterp *nextPtr;
  				/* Next in list of names associated with
  				 * interps in this process. NULL means end of
  				 * list. */
  } RegisteredInterp;
  
  /*
   * A registry of all interpreters for a display is kept in a property
   * "InterpRegistry" on the root window of the display. It is organized as a
   * series of zero or more concatenated strings (in no particular order), each
   * of the form
   *	window space name '\0'
   * where "window" is the hex id of the comm. window to use to talk to an
   * interpreter named "name".
   *
   * When the registry is being manipulated by an application (e.g. to add or
   * remove an entry), it is loaded into memory using a structure of the
   * following type:
   */
  
  typedef struct NameRegistry {
      TkDisplay *dispPtr;		/* Display from which the registry was
  				 * read. */
      int locked;			/* Non-zero means that the display was locked
  				 * when the property was read in. */
      int modified;		/* Non-zero means that the property has been
  				 * modified, so it needs to be written out
  				 * when the NameRegistry is closed. */
      unsigned long propLength;	/* Length of the property, in bytes. */
      char *property;		/* The contents of the property, or NULL if
  				 * none. See format description above; this is
  				 * *not* terminated by the first null
  				 * character. Dynamically allocated. */
      int allocedByX;		/* Non-zero means must free property with
  				 * XFree; zero means use ckfree. */
  } NameRegistry;
  
  static int initialized = false; /* A flag to denote if we have initialized
  				 * yet. */
  
  static RegisteredInterp *interpListPtr = NULL;
  				/* List of all interpreters registered by this
  				 * process. */
  
  /*
   * The information below is used for communication between processes during
   * "send" commands. Each process keeps a private window, never even mapped,
   * with one property, "Comm". When a command is sent to an interpreter, the
   * command is appended to the comm property of the communication window
   * associated with the interp's process. Similarly, when a result is returned
   * from a sent command, it is also appended to the comm property.
   *
   * Each command and each result takes the form of ASCII text. For a command,
   * the text consists of a zero character followed by several null-terminated
   * ASCII strings. The first string consists of the single letter "c".
   * Subsequent strings have the form "option value" where the following options
   * are supported:
   *
   * -r commWindow serial
   *
   *	This option means that a response should be sent to the window whose X
   *	identifier is "commWindow" (in hex), and the response should be
   *	identified with the serial number given by "serial" (in decimal). If
   *	this option isn't specified then the send is asynchronous and no
   *	response is sent.
   *
   * -n name
   *
   *	"Name" gives the name of the application for which the command is
   *	intended. This option must be present.
   *
   * -s script
   *
   *	"Script" is the script to be executed. This option must be present.
   *
   * The options may appear in any order. The -n and -s options must be present,
   * but -r may be omitted for asynchronous RPCs. For compatibility with future
   * releases that may add new features, there may be additional options
   * present; as long as they start with a "-" character, they will be ignored.
   *
   *
   * A result also consists of a zero character followed by several null-
   * terminated ASCII strings. The first string consists of the single letter
   * "r". Subsequent strings have the form "option value" where the following
   * options are supported:
   *
   * -s serial
   *
   *	Identifies the command for which this is the result. It is the same as
   *	the "serial" field from the -s option in the command. This option must
   *	be present.
   *
   * -c code
   *
   *	"Code" is the completion code for the script, in decimal. If the code
   *	is omitted it defaults to TCL_OK.
   *
   * -r result
   *
   *	"Result" is the result string for the script, which may be either a
   *	result or an error message. If this field is omitted then it defaults
   *	to an empty string.
   *
   * -i errorInfo
   *
   *	"ErrorInfo" gives a string with which to initialize the errorInfo
   *	variable. This option may be omitted; it is ignored unless the
   *	completion code is TCL_ERROR.
   *
   * -e errorCode
   *
   *	"ErrorCode" gives a string with with to initialize the errorCode
   *	variable. This option may be omitted; it is ignored unless the
   *	completion code is TCL_ERROR.
   *
   * Options may appear in any order, and only the -s option must be present. As
   * with commands, there may be additional options besides these; unknown
   * options are ignored.
   */
  
  /*
   * Maximum size property that can be read at one time by this module:
   */
  
  #define MAX_PROP_WORDS 100000
  
  /*
   * Forward declarations for procedures defined later in this file:
   */
  
  static int SendInit(Tcl_Interp *interp);
  
  /*
   *--------------------------------------------------------------
   *
   * Tk_SetAppName --
   *
   *	This procedure is called to associate an ASCII name with a Tk
   *	application. If the application has already been named, the name
   *	replaces the old one.
   *
   * Results:
   *	The return value is the name actually given to the application. This
   *	will normally be the same as name, but if name was already in use for
   *	an application then a name of the form "name #2" will be chosen, with
   *	a high enough number to make the name unique.
   *
   * Side effects:
   *	Registration info is saved, thereby allowing the "send" command to be
   *	used later to invoke commands in the application. In addition, the
   *	"send" command is created in the application's interpreter. The
   *	registration will be removed automatically if the interpreter is
   *	deleted or the "send" command is removed.
   *
   *--------------------------------------------------------------
   */
  
  CONST char *
  Tk_SetAppName(
      Tk_Window tkwin,		/* Token for any window in the application to
  				 * be named: it is just used to identify the
  				 * application and the display. */
      CONST char *name)		/* The name that will be used to refer to the
  				 * interpreter in later "send" commands. Must
  				 * be globally unique. */
  {
      TkWindow *winPtr = (TkWindow *) tkwin;
      Tcl_Interp *interp = winPtr->mainPtr->interp;
      int i, suffix, offset, result;
      RegisteredInterp *riPtr, *prevPtr;
      const char *actualName;
      Tcl_DString dString;
      Tcl_Obj *resultObjPtr, *interpNamePtr;
      char *interpName;
  
      if (!initialized) {
  	SendInit(interp);
      }
  
      /*
       * See if the application is already registered; if so, remove its current
       * name from the registry. The deletion of the command will take care of
       * disposing of this entry.
       */
  
      for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL;
  	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
  	if (riPtr->interp == interp) {
  	    if (prevPtr == NULL) {
  		interpListPtr = interpListPtr->nextPtr;
  	    } else {
  		prevPtr->nextPtr = riPtr->nextPtr;
  	    }
  	    break;
  	}
      }
  
      /*
       * Pick a name to use for the application. Use "name" if it's not already
       * in use. Otherwise add a suffix such as " #2", trying larger and larger
       * numbers until we eventually find one that is unique.
       */
  
      actualName = name;
      suffix = 1;
      offset = 0;
      Tcl_DStringInit(&dString);
  
      TkGetInterpNames(interp, tkwin);
      resultObjPtr = Tcl_GetObjResult(interp);
      Tcl_IncrRefCount(resultObjPtr);
      for (i = 0; ; ) {
  	result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr);
  	if (interpNamePtr == NULL) {
  	    break;
  	}
  	interpName = Tcl_GetString(interpNamePtr);
  	if (strcmp(actualName, interpName) == 0) {
  	    if (suffix == 1) {
  		Tcl_DStringAppend(&dString, name, -1);
  		Tcl_DStringAppend(&dString, " #", 2);
  		offset = Tcl_DStringLength(&dString);
  		Tcl_DStringSetLength(&dString, offset + 10);
  		actualName = Tcl_DStringValue(&dString);
  	    }
  	    suffix++;
  	    sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
  	    i = 0;
  	} else {
  	    i++;
  	}
      }
  
      Tcl_DecrRefCount(resultObjPtr);
      Tcl_ResetResult(interp);
  
      /*
       * We have found a unique name. Now add it to the registry.
       */
  
      riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
      riPtr->interp = interp;
      riPtr->name = ckalloc(strlen(actualName) + 1);
      riPtr->nextPtr = interpListPtr;
      interpListPtr = riPtr;
      strcpy(riPtr->name, actualName);
  
      /*
       * TODO: DeleteProc
       */
  
      Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, NULL);
      if (Tcl_IsSafe(interp)) {
  	Tcl_HideCommand(interp, "send", "send");
      }
      Tcl_DStringFree(&dString);
  
      return riPtr->name;
  }
  
  /*
   *--------------------------------------------------------------
   *
   * Tk_SendObjCmd --
   *
   *	This procedure is invoked to process the "send" Tcl command. See the
   *	user documentation for details on what it does.
   *
   * Results:
   *	A standard Tcl result.
   *
   * Side effects:
   *	See the user documentation.
   *
   *--------------------------------------------------------------
   */
  
  int
  Tk_SendObjCmd(
      ClientData clientData,	/* Used only for deletion */
      Tcl_Interp *interp,		/* The interp we are sending from */
      int objc,			/* Number of arguments */
      Tcl_Obj *CONST objv[])	/* The arguments */
  {
      const char *sendOptions[] = {"-async", "-displayof", "-", NULL};
      char *stringRep, *destName;
      int async = 0;
      int i, index, firstArg;
      RegisteredInterp *riPtr;
      Tcl_Obj *resultPtr, *listObjPtr;
      int result = TCL_OK;
  
      for (i = 1; i < (objc - 1); ) {
  	stringRep = Tcl_GetString(objv[i]);
  	if (stringRep[0] == '-') {
  	    if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0,
  		    &index) != TCL_OK) {
  		return TCL_ERROR;
  	    }
  	    if (index == 0) {
  		async = 1;
  		i++;
  	    } else if (index == 1) {
  		i += 2;
  	    } else {
  		i++;
  	    }
  	} else {
  	    break;
  	}
      }
  
      if (objc < (i + 2)) {
  	Tcl_WrongNumArgs(interp, 1, objv,
  		"?options? interpName arg ?arg ...?");
  	return TCL_ERROR;
      }
  
      destName = Tcl_GetString(objv[i]);
      firstArg = i + 1;
  
      resultPtr = Tcl_GetObjResult(interp);
  
      /*
       * See if the target interpreter is local. If so, execute the command
       * directly without going through the DDE server. The only tricky thing is
       * passing the result from the target interpreter to the invoking
       * interpreter. Watch out: they could be the same!
       */
  
      for (riPtr = interpListPtr; (riPtr != NULL)
  	    && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) {
  	/*
  	 * Empty loop body.
  	 */
      }
  
      if (riPtr != NULL) {
  	/*
  	 * This command is to a local interp. No need to go through the
  	 * server.
  	 */
  
  	Tcl_Interp *localInterp;
  
  	Tcl_Preserve(riPtr);
  	localInterp = riPtr->interp;
  	Tcl_Preserve(localInterp);
  	if (firstArg == (objc - 1)) {
  	    /*
  	     * This might be one of those cases where the new parser is
  	     * faster.
  	     */
  
  	    result = Tcl_EvalObjEx(localInterp, objv[firstArg],
  		    TCL_EVAL_DIRECT);
  	} else {
  	    listObjPtr = Tcl_NewListObj(0, NULL);
  	    for (i = firstArg; i < objc; i++) {
  		Tcl_ListObjAppendList(interp, listObjPtr, objv[i]);
  	    }
  	    Tcl_IncrRefCount(listObjPtr);
  	    result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT);
  	    Tcl_DecrRefCount(listObjPtr);
  	}
  	if (interp != localInterp) {
  	    if (result == TCL_ERROR) {
  		/* Tcl_Obj *errorObjPtr; */
  
  		/*
  		 * An error occurred, so transfer error information from the
  		 * destination interpreter back to our interpreter. Must clear
  		 * interp's result before calling Tcl_AddErrorInfo, since
  		 * Tcl_AddErrorInfo will store the interp's result in
  		 * errorInfo before appending riPtr's $errorInfo; we've
  		 * already got everything we need in riPtr's $errorInfo.
  		 */
  
  		Tcl_ResetResult(interp);
  		Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp,
  			"errorInfo", NULL, TCL_GLOBAL_ONLY));
  		/* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL,
  			TCL_GLOBAL_ONLY);
  		Tcl_SetObjErrorCode(interp, errorObjPtr); */
  	    }
  	    Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp));
  	}
  	Tcl_Release(riPtr);
  	Tcl_Release(localInterp);
      } else {
  	/*
  	 * TODO: This is a non-local request. Send the script to the server
  	 * and poll it for a result.
  	 */
      }
  
      return result;
  }
  
  /*
   *----------------------------------------------------------------------
   *
   * TkGetInterpNames --
   *
   *	This procedure is invoked to fetch a list of all the interpreter names
   *	currently registered for the display of a particular window.
   *
   * Results:
   *	A standard Tcl return value. Interp->result will be set to hold a list
   *	of all the interpreter names defined for tkwin's display. If an error
   *	occurs, then TCL_ERROR is returned and interp->result will hold an
   *	error message.
   *
   * Side effects:
   *	None.
   *
   *----------------------------------------------------------------------
   */
  
  int
  TkGetInterpNames(
      Tcl_Interp *interp,		/* Interpreter for returning a result. */
      Tk_Window tkwin)		/* Window whose display is to be used for the
  				 * lookup. */
  {
      Tcl_Obj *listObjPtr;
      RegisteredInterp *riPtr;
  
      listObjPtr = Tcl_NewListObj(0, NULL);
      riPtr = interpListPtr;
      while (riPtr != NULL) {
  	Tcl_ListObjAppendElement(interp, listObjPtr,
  		Tcl_NewStringObj(riPtr->name, -1));
  	riPtr = riPtr->nextPtr;
      }
  
      Tcl_SetObjResult(interp, listObjPtr);
      return TCL_OK;
  }
  
  /*
   *--------------------------------------------------------------
   *
   * SendInit --
   *
   *	This procedure is called to initialize the communication channels for
   *	sending commands and receiving results.
   *
   * Results:
   *	None.
   *
   * Side effects:
   *	Sets up various data structures and windows.
   *
   *--------------------------------------------------------------
   */
  
  static int
  SendInit(
      Tcl_Interp *interp)		/* Interpreter to use for error reporting (no
  				 * errors are ever returned, but the
  				 * interpreter is needed anyway). */
  {
      return TCL_OK;
  }
  