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