1/* 2 * tkMacOSXSend.c -- 3 * 4 * This file provides procedures that implement the "send" 5 * command, allowing commands to be passed from interpreter 6 * to interpreter. This current implementation for the Mac 7 * has most functionality stubed out. 8 * 9 * The current plan, which we have not had time to implement, is 10 * for the first Wish app to create a gestalt of type 'WIsH'. 11 * This gestalt will point to a table, in system memory, of 12 * Tk apps. Each Tk app, when it starts up, will register their 13 * name, and process ID, in this table. This will allow us to 14 * implement "tk appname". 15 * 16 * Then the send command will look up the process id of the target 17 * app in this table, and send an AppleEvent to that process. The 18 * AppleEvent handler is much like the do script handler, except that 19 * you have to specify the name of the tk app as well, since there may 20 * be many interps in one wish app, and you need to send it to the 21 * right one. 22 * 23 * Implementing this has been on our list of things to do, but what 24 * with the demise of Tcl at Sun, and the lack of resources at 25 * Scriptics it may not get done for awhile. So this sketch is 26 * offered for the brave to attempt if they need the functionality... 27 * 28 * Copyright (c) 1989-1994 The Regents of the University of California. 29 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 30 * Copyright 2001, Apple Computer, Inc. 31 * Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net> 32 * 33 * See the file "license.terms" for information on usage and redistribution 34 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 35 * 36 * RCS: @(#) $Id: tkMacOSXSend.c,v 1.2.2.4 2007/06/04 09:28:45 das Exp $ 37 */ 38 39#include "tkMacOSXInt.h" 40 41/* 42 * The following structure is used to keep track of the 43 * interpreters registered by this process. 44 */ 45 46typedef struct RegisteredInterp { 47 char *name; /* Interpreter's name (malloc-ed). */ 48 Tcl_Interp *interp; /* Interpreter associated with 49 * name. */ 50 struct RegisteredInterp *nextPtr; 51 /* Next in list of names associated 52 * with interps in this process. 53 * NULL means end of list. */ 54} RegisteredInterp; 55 56/* 57 * A registry of all interpreters for a display is kept in a 58 * property "InterpRegistry" on the root window of the display. 59 * It is organized as a series of zero or more concatenated strings 60 * (in no particular order), each of the form 61 * window space name '\0' 62 * where "window" is the hex id of the comm. window to use to talk 63 * to an interpreter named "name". 64 * 65 * When the registry is being manipulated by an application (e.g. to 66 * add or remove an entry), it is loaded into memory using a structure 67 * of the following type: 68 */ 69 70typedef struct NameRegistry { 71 TkDisplay *dispPtr; /* Display from which the registry was 72 * read. */ 73 int locked; /* Non-zero means that the display was 74 * locked when the property was read in. */ 75 int modified; /* Non-zero means that the property has 76 * been modified, so it needs to be written 77 * out when the NameRegistry is closed. */ 78 unsigned long propLength; /* Length of the property, in bytes. */ 79 char *property; /* The contents of the property, or NULL 80 * if none. See format description above; 81 * this is *not* terminated by the first 82 * null character. Dynamically allocated. */ 83 int allocedByX; /* Non-zero means must free property with 84 * XFree; zero means use ckfree. */ 85} NameRegistry; 86 87static int initialized = false; /* A flag to denote if we have initialized yet. */ 88 89static RegisteredInterp *interpListPtr = NULL; 90/* List of all interpreters 91 * registered by this process. */ 92 93 /* 94 * The information below is used for communication between processes 95 * during "send" commands. Each process keeps a private window, never 96 * even mapped, with one property, "Comm". When a command is sent to 97 * an interpreter, the command is appended to the comm property of the 98 * communication window associated with the interp's process. Similarly, 99 * when a result is returned from a sent command, it is also appended 100 * to the comm property. 101 * 102 * Each command and each result takes the form of ASCII text. For a 103 * command, the text consists of a zero character followed by several 104 * null-terminated ASCII strings. The first string consists of the 105 * single letter "c". Subsequent strings have the form "option value" 106 * where the following options are supported: 107 * 108 * -r commWindow serial 109 * 110 * This option means that a response should be sent to the window 111 * whose X identifier is "commWindow" (in hex), and the response should 112 * be identified with the serial number given by "serial" (in decimal). 113 * If this option isn't specified then the send is asynchronous and 114 * no response is sent. 115 * 116 * -n name 117 * "Name" gives the name of the application for which the command is 118 * intended. This option must be present. 119 * 120 * -s script 121 * 122 * "Script" is the script to be executed. This option must be present. 123 * 124 * The options may appear in any order. The -n and -s options must be 125 * present, but -r may be omitted for asynchronous RPCs. For compatibility 126 * with future releases that may add new features, there may be additional 127 * options present; as long as they start with a "-" character, they will 128 * be ignored. 129 * 130 * A result also consists of a zero character followed by several null- 131 * terminated ASCII strings. The first string consists of the single 132 * letter "r". Subsequent strings have the form "option value" where 133 * the following options are supported: 134 * 135 * -s serial 136 * 137 * Identifies the command for which this is the result. It is the 138 * same as the "serial" field from the -s option in the command. This 139 * option must be present. 140 * 141 * -c code 142 * 143 * "Code" is the completion code for the script, in decimal. If the 144 * code is omitted it defaults to TCL_OK. 145 * 146 * -r result 147 * 148 * "Result" is the result string for the script, which may be either 149 * a result or an error message. If this field is omitted then it 150 * defaults to an empty string. 151 * 152 * -i errorInfo 153 * 154 * "ErrorInfo" gives a string with which to initialize the errorInfo 155 * variable. This option may be omitted; it is ignored unless the 156 * completion code is TCL_ERROR. 157 * 158 * -e errorCode 159 * 160 * "ErrorCode" gives a string with with to initialize the errorCode 161 * variable. This option may be omitted; it is ignored unless the 162 * completion code is TCL_ERROR. 163 * 164 * Options may appear in any order, and only the -s option must be 165 * present. As with commands, there may be additional options besides 166 * these; unknown options are ignored. 167 */ 168 169 /* 170 * Maximum size property that can be read at one time by 171 * this module: 172 */ 173 174#define MAX_PROP_WORDS 100000 175 176/* 177 * Forward declarations for procedures defined later in this file: 178 */ 179 180static int SendInit(Tcl_Interp *interp); 181 182 183/* 184 *-------------------------------------------------------------- 185 * 186 * Tk_SetAppName -- 187 * 188 * This procedure is called to associate an ASCII name with a Tk 189 * application. If the application has already been named, the 190 * name replaces the old one. 191 * 192 * Results: 193 * The return value is the name actually given to the application. 194 * This will normally be the same as name, but if name was already 195 * in use for an application then a name of the form "name #2" will 196 * be chosen, with a high enough number to make the name unique. 197 * 198 * Side effects: 199 * Registration info is saved, thereby allowing the "send" command 200 * to be used later to invoke commands in the application. In 201 * addition, the "send" command is created in the application's 202 * interpreter. The registration will be removed automatically 203 * if the interpreter is deleted or the "send" command is removed. 204 * 205 *-------------------------------------------------------------- 206 */ 207 208CONST char * 209Tk_SetAppName( 210 Tk_Window tkwin, /* Token for any window in the application 211 * to be named: it is just used to identify 212 * the application and the display. */ 213 CONST char *name) /* The name that will be used to 214 * refer to the interpreter in later 215 * "send" commands. Must be globally 216 * unique. */ 217{ 218 TkWindow *winPtr = (TkWindow *) tkwin; 219 Tcl_Interp *interp = winPtr->mainPtr->interp; 220 int i, suffix, offset, result; 221 RegisteredInterp *riPtr, *prevPtr; 222 const char *actualName; 223 Tcl_DString dString; 224 Tcl_Obj *resultObjPtr, *interpNamePtr; 225 char *interpName; 226 227 if (!initialized) { 228 SendInit(interp); 229 } 230 231 /* 232 * See if the application is already registered; if so, remove its 233 * current name from the registry. The deletion of the command 234 * will take care of disposing of this entry. 235 */ 236 237 for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; 238 prevPtr = riPtr, riPtr = riPtr->nextPtr) { 239 if (riPtr->interp == interp) { 240 if (prevPtr == NULL) { 241 interpListPtr = interpListPtr->nextPtr; 242 } else { 243 prevPtr->nextPtr = riPtr->nextPtr; 244 } 245 break; 246 } 247 } 248 249 /* 250 * Pick a name to use for the application. Use "name" if it's not 251 * already in use. Otherwise add a suffix such as " #2", trying 252 * larger and larger numbers until we eventually find one that is 253 * unique. 254 */ 255 256 actualName = name; 257 suffix = 1; 258 offset = 0; 259 Tcl_DStringInit(&dString); 260 261 TkGetInterpNames(interp, tkwin); 262 resultObjPtr = Tcl_GetObjResult(interp); 263 Tcl_IncrRefCount(resultObjPtr); 264 for (i = 0; ; ) { 265 result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr); 266 if (interpNamePtr == NULL) { 267 break; 268 } 269 interpName = Tcl_GetString(interpNamePtr); 270 if (strcmp(actualName, interpName) == 0) { 271 if (suffix == 1) { 272 Tcl_DStringAppend(&dString, name, -1); 273 Tcl_DStringAppend(&dString, " #", 2); 274 offset = Tcl_DStringLength(&dString); 275 Tcl_DStringSetLength(&dString, offset + 10); 276 actualName = Tcl_DStringValue(&dString); 277 } 278 suffix++; 279 sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); 280 i = 0; 281 } else { 282 i++; 283 } 284 } 285 286 Tcl_DecrRefCount(resultObjPtr); 287 Tcl_ResetResult(interp); 288 289 /* 290 * We have found a unique name. Now add it to the registry. 291 */ 292 293 riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); 294 riPtr->interp = interp; 295 riPtr->name = ckalloc(strlen(actualName) + 1); 296 riPtr->nextPtr = interpListPtr; 297 interpListPtr = riPtr; 298 strcpy(riPtr->name, actualName); 299 300 /* 301 * TODO: DeleteProc 302 */ 303 304 Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, 305 (ClientData) riPtr, NULL); 306 if (Tcl_IsSafe(interp)) { 307 Tcl_HideCommand(interp, "send", "send"); 308 } 309 Tcl_DStringFree(&dString); 310 311 return riPtr->name; 312} 313 314/* 315 *-------------------------------------------------------------- 316 * 317 * Tk_SendObjCmd -- 318 * 319 * This procedure is invoked to process the "send" Tcl command. 320 * See the user documentation for details on what it does. 321 * 322 * Results: 323 * A standard Tcl result. 324 * 325 * Side effects: 326 * See the user documentation. 327 * 328 *-------------------------------------------------------------- 329 */ 330 331int 332Tk_SendObjCmd( 333 ClientData clientData, /* Used only for deletion */ 334 Tcl_Interp *interp, /* The interp we are sending from */ 335 int objc, /* Number of arguments */ 336 Tcl_Obj *CONST objv[]) /* The arguments */ 337{ 338 const char *sendOptions[] = {"-async", "-displayof", "-", NULL}; 339 char *stringRep, *destName; 340 int async = 0; 341 int i, index, firstArg; 342 RegisteredInterp *riPtr; 343 Tcl_Obj *resultPtr, *listObjPtr; 344 int result = TCL_OK; 345 346 for (i = 1; i < (objc - 1); ) { 347 stringRep = Tcl_GetString(objv[i]); 348 if (stringRep[0] == '-') { 349 if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0, 350 &index) != TCL_OK) { 351 return TCL_ERROR; 352 } 353 if (index == 0) { 354 async = 1; 355 i++; 356 } else if (index == 1) { 357 i += 2; 358 } else { 359 i++; 360 } 361 } else { 362 break; 363 } 364 } 365 366 if (objc < (i + 2)) { 367 Tcl_WrongNumArgs(interp, 1, objv, 368 "?options? interpName arg ?arg ...?"); 369 return TCL_ERROR; 370 } 371 372 destName = Tcl_GetString(objv[i]); 373 firstArg = i + 1; 374 375 resultPtr = Tcl_GetObjResult(interp); 376 377 /* 378 * See if the target interpreter is local. If so, execute 379 * the command directly without going through the DDE server. 380 * The only tricky thing is passing the result from the target 381 * interpreter to the invoking interpreter. Watch out: they 382 * could be the same! 383 */ 384 385 for (riPtr = interpListPtr; (riPtr != NULL) 386 && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) { 387 /* 388 * Empty loop body. 389 */ 390 391 } 392 393 if (riPtr != NULL) { 394 /* 395 * This command is to a local interp. No need to go through 396 * the server. 397 */ 398 399 Tcl_Interp *localInterp; 400 401 Tcl_Preserve((ClientData) riPtr); 402 localInterp = riPtr->interp; 403 Tcl_Preserve((ClientData) localInterp); 404 if (firstArg == (objc - 1)) { 405 /* 406 * This might be one of those cases where the new 407 * parser is faster. 408 */ 409 410 result = Tcl_EvalObjEx(localInterp, objv[firstArg], TCL_EVAL_DIRECT); 411 } else { 412 listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 413 for (i = firstArg; i < objc; i++) { 414 Tcl_ListObjAppendList(interp, listObjPtr, objv[i]); 415 } 416 Tcl_IncrRefCount(listObjPtr); 417 result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT); 418 Tcl_DecrRefCount(listObjPtr); 419 } 420 if (interp != localInterp) { 421 if (result == TCL_ERROR) { 422 /* Tcl_Obj *errorObjPtr; */ 423 424 /* 425 * An error occurred, so transfer error information from the 426 * destination interpreter back to our interpreter. Must clear 427 * interp's result before calling Tcl_AddErrorInfo, since 428 * Tcl_AddErrorInfo will store the interp's result in errorInfo 429 * before appending riPtr's $errorInfo; we've already got 430 * everything we need in riPtr's $errorInfo. 431 */ 432 433 Tcl_ResetResult(interp); 434 Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp, 435 "errorInfo", NULL, TCL_GLOBAL_ONLY)); 436 /* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL, 437 TCL_GLOBAL_ONLY); 438 Tcl_SetObjErrorCode(interp, errorObjPtr); */ 439 } 440 Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); 441 } 442 Tcl_Release((ClientData) riPtr); 443 Tcl_Release((ClientData) localInterp); 444 } else { 445 /* 446 * TODO: This is a non-local request. Send the script to the server and 447 * poll it for a result. 448 */ 449 } 450 451 return result; 452} 453 454/* 455 *---------------------------------------------------------------------- 456 * 457 * TkGetInterpNames -- 458 * 459 * This procedure is invoked to fetch a list of all the 460 * interpreter names currently registered for the display 461 * of a particular window. 462 * 463 * Results: 464 * A standard Tcl return value. Interp->result will be set 465 * to hold a list of all the interpreter names defined for 466 * tkwin's display. If an error occurs, then TCL_ERROR 467 * is returned and interp->result will hold an error message. 468 * 469 * Side effects: 470 * None. 471 * 472 *---------------------------------------------------------------------- 473 */ 474 475int 476TkGetInterpNames( 477 Tcl_Interp *interp, /* Interpreter for returning a result. */ 478 Tk_Window tkwin) /* Window whose display is to be used 479 * for the lookup. */ 480{ 481 Tcl_Obj *listObjPtr; 482 RegisteredInterp *riPtr; 483 484 listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 485 riPtr = interpListPtr; 486 while (riPtr != NULL) { 487 Tcl_ListObjAppendElement(interp, listObjPtr, 488 Tcl_NewStringObj(riPtr->name, -1)); 489 riPtr = riPtr->nextPtr; 490 } 491 492 Tcl_SetObjResult(interp, listObjPtr); 493 return TCL_OK; 494} 495 496/* 497 *-------------------------------------------------------------- 498 * 499 * SendInit -- 500 * 501 * This procedure is called to initialize the 502 * communication channels for sending commands and 503 * receiving results. 504 * 505 * Results: 506 * None. 507 * 508 * Side effects: 509 * Sets up various data structures and windows. 510 * 511 *-------------------------------------------------------------- 512 */ 513 514static int 515SendInit( 516 Tcl_Interp *interp) /* Interpreter to use for error reporting 517 * (no errors are ever returned, but the 518 * interpreter is needed anyway). */ 519{ 520 return TCL_OK; 521} 522