ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tk 8.5.15 (as of svn r89086)

Browse Source
This commit is contained in:
Zachary Ware
2017-09-04 14:25:47 -05:00
parent 4b29e0458f
commit 27e7dfc7da
883 changed files with 499023 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

515
macosx/tkMacOSXSend.c Normal file
View File

@@ -0,0 +1,515 @@
/*
* 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-2009, Apple Inc.
* Copyright (c) 2005-2009 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 = 0; /* 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 (result != TCL_OK || 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 *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,
"?-option value ...? interpName arg ?arg ...?");
return TCL_ERROR;
}
destName = Tcl_GetString(objv[i]);
firstArg = i + 1;
/*
* 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;
}
/*
* Local Variables:
* mode: objc
* c-basic-offset: 4
* fill-column: 79
* coding: utf-8
* End:
*/