tk/mac/tkMacSend.c

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