home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tkTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-08  |  37.6 KB  |  1,295 lines
  1. /* 
  2.  * tclTest.c --
  3.  *
  4.  *    This file contains C command procedures for a bunch of additional
  5.  *    Tcl commands that are used for testing out Tcl's C interfaces.
  6.  *    These commands are not normally included in Tcl applications;
  7.  *    they're only used for testing.
  8.  *
  9.  * Copyright (c) 1993-1994 The Regents of the University of California.
  10.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  */
  15.  
  16. static char sccsid[] = "@(#) tkTest.c 1.25 95/06/08 11:43:02";
  17.  
  18. #include "tkInt.h"
  19. #include "tkPort.h"    
  20.  
  21. /*
  22.  * The following variable is a special hack that is needed in order for
  23.  * Sun shared libraries to be used for Tcl.
  24.  */
  25.  
  26. extern int matherr();
  27. int *tclDummyMathPtr = (int *) matherr;
  28.  
  29. /*
  30.  * The table below describes events and is used by the "testevent"
  31.  * command.
  32.  */
  33.  
  34. typedef struct {
  35.     char *name;            /* Name of event. */
  36.     int type;            /* Event type for X, such as
  37.                  * ButtonPress. */
  38. } EventInfo;
  39.  
  40. static EventInfo eventArray[] = {
  41.     {"Motion",        MotionNotify},
  42.     {"Button",        ButtonPress},
  43.     {"ButtonPress",    ButtonPress},
  44.     {"ButtonRelease",    ButtonRelease},
  45.     {"Colormap",    ColormapNotify},
  46.     {"Enter",        EnterNotify},
  47.     {"Leave",        LeaveNotify},
  48.     {"Expose",        Expose},
  49.     {"FocusIn",        FocusIn},
  50.     {"FocusOut",    FocusOut},
  51.     {"Keymap",        KeymapNotify},
  52.     {"Key",        KeyPress},
  53.     {"KeyPress",    KeyPress},
  54.     {"KeyRelease",    KeyRelease},
  55.     {"Property",    PropertyNotify},
  56.     {"ResizeRequest",    ResizeRequest},
  57.     {"Circulate",    CirculateNotify},
  58.     {"Configure",    ConfigureNotify},
  59.     {"Destroy",        DestroyNotify},
  60.     {"Gravity",        GravityNotify},
  61.     {"Map",        MapNotify},
  62.     {"Reparent",    ReparentNotify},
  63.     {"Unmap",        UnmapNotify},
  64.     {"Visibility",    VisibilityNotify},
  65.     {"CirculateRequest",CirculateRequest},
  66.     {"ConfigureRequest",ConfigureRequest},
  67.     {"MapRequest",    MapRequest},
  68.     {(char *) NULL,    0}
  69. };
  70.  
  71. /*
  72.  * The defines and table below are used to classify events into
  73.  * various groups.  The reason for this is that logically identical
  74.  * fields (e.g. "state") appear at different places in different
  75.  * types of events.  The classification masks can be used to figure
  76.  * out quickly where to extract information from events.
  77.  */
  78.  
  79. #define KEY_BUTTON_MOTION    0x1
  80. #define CROSSING        0x2
  81. #define FOCUS            0x4
  82. #define EXPOSE            0x8
  83. #define VISIBILITY        0x10
  84. #define CREATE            0x20
  85. #define MAP            0x40
  86. #define REPARENT        0x80
  87. #define CONFIG            0x100
  88. #define CONFIG_REQ        0x200
  89. #define RESIZE_REQ        0x400
  90. #define GRAVITY            0x800
  91. #define PROP            0x1000
  92. #define SEL_CLEAR        0x2000
  93. #define SEL_REQ            0x4000
  94. #define SEL_NOTIFY        0x8000
  95. #define COLORMAP        0x10000
  96. #define MAPPING            0x20000
  97.  
  98. static int flagArray[LASTEvent] = {
  99.    /* Not used */        0,
  100.    /* Not used */        0,
  101.    /* KeyPress */        KEY_BUTTON_MOTION,
  102.    /* KeyRelease */        KEY_BUTTON_MOTION,
  103.    /* ButtonPress */        KEY_BUTTON_MOTION,
  104.    /* ButtonRelease */        KEY_BUTTON_MOTION,
  105.    /* MotionNotify */        KEY_BUTTON_MOTION,
  106.    /* EnterNotify */        CROSSING,
  107.    /* LeaveNotify */        CROSSING,
  108.    /* FocusIn */        FOCUS,
  109.    /* FocusOut */        FOCUS,
  110.    /* KeymapNotify */        0,
  111.    /* Expose */            EXPOSE,
  112.    /* GraphicsExpose */        EXPOSE,
  113.    /* NoExpose */        0,
  114.    /* VisibilityNotify */    VISIBILITY,
  115.    /* CreateNotify */        CREATE,
  116.    /* DestroyNotify */        0,
  117.    /* UnmapNotify */        0,
  118.    /* MapNotify */        MAP,
  119.    /* MapRequest */        0,
  120.    /* ReparentNotify */        REPARENT,
  121.    /* ConfigureNotify */    CONFIG,
  122.    /* ConfigureRequest */    CONFIG_REQ,
  123.    /* GravityNotify */        0,
  124.    /* ResizeRequest */        RESIZE_REQ,
  125.    /* CirculateNotify */    0,
  126.    /* CirculateRequest */    0,
  127.    /* PropertyNotify */        PROP,
  128.    /* SelectionClear */        SEL_CLEAR,
  129.    /* SelectionRequest */    SEL_REQ,
  130.    /* SelectionNotify */    SEL_NOTIFY,
  131.    /* ColormapNotify */        COLORMAP,
  132.    /* ClientMessage */        0,
  133.    /* MappingNotify */        MAPPING
  134. };
  135.  
  136. /*
  137.  * The following data structure represents the master for a test
  138.  * image:
  139.  */
  140.  
  141. typedef struct TImageMaster {
  142.     Tk_ImageMaster master;    /* Tk's token for image master. */
  143.     Tcl_Interp *interp;        /* Interpreter for application. */
  144.     int width, height;        /* Dimensions of image. */
  145.     char *imageName;        /* Name of image (malloc-ed). */
  146.     char *varName;        /* Name of variable in which to log
  147.                  * events for image (malloc-ed). */
  148. } TImageMaster;
  149.  
  150. /*
  151.  * The following data structure represents a particular use of a
  152.  * particular test image.
  153.  */
  154.  
  155. typedef struct TImageInstance {
  156.     TImageMaster *masterPtr;    /* Pointer to master for image. */
  157.     XColor *fg;            /* Foreground color for drawing in image. */
  158.     GC gc;            /* Graphics context for drawing in image. */
  159. } TImageInstance;
  160.  
  161. /*
  162.  * The type record for test images:
  163.  */
  164.  
  165. static int        ImageCreate _ANSI_ARGS_((Tcl_Interp *interp,
  166.                 char *name, int argc, char **argv,
  167.                 Tk_ImageType *typePtr, Tk_ImageMaster master,
  168.                 ClientData *clientDataPtr));
  169. static ClientData    ImageGet _ANSI_ARGS_((Tk_Window tkwin,
  170.                 ClientData clientData));
  171. static void        ImageDisplay _ANSI_ARGS_((ClientData clientData,
  172.                 Display *display, Drawable drawable, 
  173.                 int imageX, int imageY, int width,
  174.                 int height, int drawableX,
  175.                 int drawableY));
  176. static void        ImageFree _ANSI_ARGS_((ClientData clientData,
  177.                 Display *display));
  178. static void        ImageDelete _ANSI_ARGS_((ClientData clientData));
  179.  
  180. static Tk_ImageType imageType = {
  181.     "test",            /* name */
  182.     ImageCreate,        /* createProc */
  183.     ImageGet,            /* getProc */
  184.     ImageDisplay,        /* displayProc */
  185.     ImageFree,            /* freeProc */
  186.     ImageDelete,        /* deleteProc */
  187.     (Tk_ImageType *) NULL    /* nextPtr */
  188. };
  189.  
  190. /*
  191.  * One of the following structures describes each of the interpreters
  192.  * created by the "testnewapp" command.  This information is used by
  193.  * the "testdeleteinterps" command to destroy all of those interpreters.
  194.  */
  195.  
  196. typedef struct NewApp {
  197.     Tcl_Interp *interp;        /* Token for interpreter. */
  198.     struct NewApp *nextPtr;    /* Next in list of new interpreters. */
  199. } NewApp;
  200.  
  201. static NewApp *newAppPtr = NULL;
  202.                 /* First in list of all new interpreters. */
  203.  
  204. /*
  205.  * Declaration for the square widget's class command procedure:
  206.  */
  207.  
  208. extern int SquareCmd _ANSI_ARGS_((ClientData clientData,
  209.     Tcl_Interp *interp, int argc, char *argv[]));
  210.  
  211. /*
  212.  * Forward declarations for procedures defined later in this file:
  213.  */
  214.  
  215. static int        ImageCmd _ANSI_ARGS_((ClientData dummy,
  216.                 Tcl_Interp *interp, int argc, char **argv));
  217. static int        TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy,
  218.                 Tcl_Interp *interp, int argc, char **argv));
  219. static int        TesteventCmd _ANSI_ARGS_((ClientData dummy,
  220.                 Tcl_Interp *interp, int argc, char **argv));
  221. static int        TestfeventCmd _ANSI_ARGS_((ClientData dummy,
  222.                 Tcl_Interp *interp, int argc, char **argv));
  223. static int        TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
  224.                 Tcl_Interp *interp, int argc, char **argv));
  225. static int        TestnewappCmd _ANSI_ARGS_((ClientData dummy,
  226.                 Tcl_Interp *interp, int argc, char **argv));
  227. static int        TestsendCmd _ANSI_ARGS_((ClientData dummy,
  228.                 Tcl_Interp *interp, int argc, char **argv));
  229.  
  230. /*
  231.  *----------------------------------------------------------------------
  232.  *
  233.  * main --
  234.  *
  235.  *    This is the main program for the application.
  236.  *
  237.  * Results:
  238.  *    None: Tk_Main never returns here, so this procedure never
  239.  *    returns either.
  240.  *
  241.  * Side effects:
  242.  *    Whatever the application does.
  243.  *
  244.  *----------------------------------------------------------------------
  245.  */
  246.  
  247. int
  248. main(argc, argv)
  249.     int argc;            /* Number of command-line arguments. */
  250.     char **argv;        /* Values of command-line arguments. */
  251. {
  252.     Tk_Main(argc, argv, Tcl_AppInit);
  253.     return 0;            /* Needed only to prevent compiler warning. */
  254. }
  255.  
  256. /*
  257.  *----------------------------------------------------------------------
  258.  *
  259.  * Tcl_AppInit --
  260.  *
  261.  *    This procedure performs application-specific initialization.
  262.  *    Most applications, especially those that incorporate additional
  263.  *    packages, will have their own version of this procedure.
  264.  *
  265.  * Results:
  266.  *    Returns a standard Tcl completion code, and leaves an error
  267.  *    message in interp->result if an error occurs.
  268.  *
  269.  * Side effects:
  270.  *    Depends on the startup script.
  271.  *
  272.  *----------------------------------------------------------------------
  273.  */
  274.  
  275. int
  276. Tcl_AppInit(interp)
  277.     Tcl_Interp *interp;        /* Interpreter for application. */
  278. {
  279.     Tk_Window main;
  280.  
  281.     main = Tk_MainWindow(interp);
  282.     if (main == NULL) {
  283.     return TCL_ERROR;
  284.     }
  285.  
  286.     /*
  287.      * Call the init procedures for included packages.  Each call should
  288.      * look like this:
  289.      *
  290.      * if (Mod_Init(interp) == TCL_ERROR) {
  291.      *     return TCL_ERROR;
  292.      * }
  293.      *
  294.      * where "Mod" is the name of the module.
  295.      */
  296.  
  297.     if (Tcl_Init(interp) == TCL_ERROR) {
  298.     return TCL_ERROR;
  299.     }
  300.     if (Tk_Init(interp) == TCL_ERROR) {
  301.     return TCL_ERROR;
  302.     }
  303.  
  304.     /*
  305.      * Create additional commands for testing Tk.
  306.      */
  307.  
  308.     Tcl_CreateCommand(interp, "square", SquareCmd,
  309.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  310.     Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd,
  311.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  312.     Tcl_CreateCommand(interp, "testevent", TesteventCmd,
  313.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  314.     Tcl_CreateCommand(interp, "testfevent", TestfeventCmd,
  315.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  316.     Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
  317.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  318.     Tcl_CreateCommand(interp, "testnewapp", TestnewappCmd,
  319.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  320.     Tcl_CreateCommand(interp, "testsend", TestsendCmd,
  321.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  322.  
  323.     /*
  324.      * Create test image type.
  325.      */
  326.  
  327.     Tk_CreateImageType(&imageType);
  328.  
  329.     /*
  330.      * Specify a user-specific startup file to invoke if the application
  331.      * is run interactively.  Typically the startup file is "~/.apprc"
  332.      * where "app" is the name of the application.  If this line is deleted
  333.      * then no user-specific startup file will be run under any conditions.
  334.      */
  335.  
  336.     tcl_RcFileName = "~/.wishrc";
  337.     return TCL_OK;
  338. }
  339.  
  340. /*
  341.  *----------------------------------------------------------------------
  342.  *
  343.  * TestdeleteappsCmd --
  344.  *
  345.  *    This procedure implements the "testdeleteapps" command.  It cleans
  346.  *    up all the interpreters left behind by the "testnewapp" command.
  347.  *
  348.  * Results:
  349.  *    A standard Tcl result.
  350.  *
  351.  * Side effects:
  352.  *    All the intepreters created by previous calls to "testnewapp"
  353.  *    get deleted.
  354.  *
  355.  *----------------------------------------------------------------------
  356.  */
  357.  
  358.     /* ARGSUSED */
  359. static int
  360. TestdeleteappsCmd(clientData, interp, argc, argv)
  361.     ClientData clientData;        /* Main window for application. */
  362.     Tcl_Interp *interp;            /* Current interpreter. */
  363.     int argc;                /* Number of arguments. */
  364.     char **argv;            /* Argument strings. */
  365. {
  366.     NewApp *nextPtr;
  367.  
  368.     while (newAppPtr != NULL) {
  369.     nextPtr = newAppPtr->nextPtr;
  370.     Tcl_DeleteInterp(newAppPtr->interp);
  371.     ckfree((char *) newAppPtr);
  372.     newAppPtr = nextPtr;
  373.     }
  374.     return TCL_OK;
  375. }
  376.  
  377. /*
  378.  *----------------------------------------------------------------------
  379.  *
  380.  * TesteventCmd --
  381.  *
  382.  *    This procedure implements the "testevent" command.  It allows
  383.  *    events to be generated on the fly, for testing event-handling.
  384.  *
  385.  * Results:
  386.  *    A standard Tcl result.
  387.  *
  388.  * Side effects:
  389.  *    Creates and handles events.
  390.  *
  391.  *----------------------------------------------------------------------
  392.  */
  393.  
  394.     /* ARGSUSED */
  395. static int
  396. TesteventCmd(clientData, interp, argc, argv)
  397.     ClientData clientData;        /* Main window for application. */
  398.     Tcl_Interp *interp;            /* Current interpreter. */
  399.     int argc;                /* Number of arguments. */
  400.     char **argv;            /* Argument strings. */
  401. {
  402.     Tk_Window main = (Tk_Window) clientData;
  403.     Tk_Window tkwin, tkwin2;
  404.     XEvent event;
  405.     EventInfo *eiPtr;
  406.     char *field, *value;
  407.     int i, number, flags;
  408.     KeySym keysym;
  409.  
  410.     if ((argc < 3) || !(argc & 1)) {
  411.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  412.         " window type ?field value field value ...?\"",
  413.         (char *) NULL);
  414.     return TCL_ERROR;
  415.     }
  416.     tkwin = Tk_NameToWindow(interp, argv[1], main);
  417.     if (tkwin == NULL) {
  418.     return TCL_ERROR;
  419.     }
  420.  
  421.     /*
  422.      * Get the type of the event.
  423.      */
  424.  
  425.     memset((VOID *) &event, 0, sizeof(event));
  426.     for (eiPtr = eventArray; ; eiPtr++) {
  427.     if (eiPtr->name == NULL) {
  428.         Tcl_AppendResult(interp, "bad event type \"", argv[2],
  429.             "\"", (char *) NULL);
  430.         return TCL_ERROR;
  431.     }
  432.     if (strcmp(eiPtr->name, argv[2]) == 0) {
  433.         event.xany.type = eiPtr->type;
  434.         break;
  435.     }
  436.     }
  437.  
  438.     /*
  439.      * Fill in fields that are common to all events.
  440.      */
  441.  
  442.     event.xany.serial = NextRequest(Tk_Display(tkwin));
  443.     event.xany.send_event = False;
  444.     event.xany.window = Tk_WindowId(tkwin);
  445.     event.xany.display = Tk_Display(tkwin);
  446.  
  447.     /*
  448.      * Process the remaining arguments to fill in additional fields
  449.      * of the event.
  450.      */
  451.  
  452.     flags = flagArray[event.xany.type];
  453.     for (i = 3; i < argc; i += 2) {
  454.     field = argv[i];
  455.     value = argv[i+1];
  456.     if (strcmp(field, "-above") == 0) {
  457.         tkwin2 = Tk_NameToWindow(interp, value, main);
  458.         if (tkwin2 == NULL) {
  459.         return TCL_ERROR;
  460.         }
  461.         event.xconfigure.above = Tk_WindowId(tkwin2);
  462.     } else if (strcmp(field, "-borderwidth") == 0) {
  463.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  464.         return TCL_ERROR;
  465.         }
  466.         event.xcreatewindow.border_width = number;
  467.     } else if (strcmp(field, "-button") == 0) {
  468.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  469.         return TCL_ERROR;
  470.         }
  471.         event.xbutton.button = number;
  472.     } else if (strcmp(field, "-count") == 0) {
  473.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  474.         return TCL_ERROR;
  475.         }
  476.         if (flags & EXPOSE) {
  477.         event.xexpose.count = number;
  478.         } else if (flags & MAPPING) {
  479.         event.xmapping.count = number;
  480.         }
  481.     } else if (strcmp(field, "-detail") == 0) {
  482.         if (flags & (CROSSING|FOCUS)) {
  483.         if (strcmp(value, "NotifyAncestor") == 0) {
  484.             number = NotifyAncestor;
  485.         } else if (strcmp(value, "NotifyVirtual") == 0) {
  486.             number = NotifyVirtual;
  487.         } else if (strcmp(value, "NotifyInferior") == 0) {
  488.             number = NotifyInferior;
  489.         } else if (strcmp(value, "NotifyNonlinear") == 0) {
  490.             number = NotifyNonlinear;
  491.         } else if (strcmp(value, "NotifyNonlinearVirtual") == 0) {
  492.             number = NotifyNonlinearVirtual;
  493.         } else if (strcmp(value, "NotifyPointer") == 0) {
  494.             number = NotifyPointer;
  495.         } else if (strcmp(value, "NotifyPointerRoot") == 0) {
  496.             number = NotifyPointerRoot;
  497.         } else if (strcmp(value, "NotifyDetailNone") == 0) {
  498.             number = NotifyDetailNone;
  499.         } else {
  500.             Tcl_AppendResult(interp, "bad detail \"", value, "\"",
  501.                 (char *) NULL);
  502.             return TCL_ERROR;
  503.         }
  504.         if (flags & FOCUS) {
  505.             event.xfocus.detail = number;
  506.         } else {
  507.             event.xcrossing.detail = number;
  508.         }
  509.         } else if (flags & CONFIG_REQ) {
  510.         if (strcmp(value, "Above") == 0) {
  511.             number = Above;
  512.         } else if (strcmp(value, "Below") == 0) {
  513.             number = Below;
  514.         } else if (strcmp(value, "TopIf") == 0) {
  515.             number = TopIf;
  516.         } else if (strcmp(value, "BottomIf") == 0) {
  517.             number = BottomIf;
  518.         } else if (strcmp(value, "Opposite") == 0) {
  519.             number = Opposite;
  520.         } else {
  521.             Tcl_AppendResult(interp, "bad detail \"", value, "\"",
  522.                 (char *) NULL);
  523.             return TCL_ERROR;
  524.         }
  525.         event.xconfigurerequest.detail = number;
  526.         }
  527.     } else if (strcmp(field, "-focus") == 0) {
  528.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  529.         return TCL_ERROR;
  530.         }
  531.         event.xcrossing.focus = number;
  532.     } else if (strcmp(field, "-height") == 0) {
  533.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  534.         return TCL_ERROR;
  535.         }
  536.         if (flags & EXPOSE) {
  537.          event.xexpose.height = number;
  538.         } else if (flags & (CONFIG|CONFIG_REQ)) {
  539.         event.xconfigure.height = number;
  540.         } else if (flags & RESIZE_REQ) {
  541.         event.xresizerequest.height = number;
  542.         }
  543.     } else if (strcmp(field, "-keycode") == 0) {
  544.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  545.         return TCL_ERROR;
  546.         }
  547.         event.xkey.keycode = number;
  548.     } else if (strcmp(field, "-keysym") == 0) {
  549.         keysym = XStringToKeysym(value);
  550.         if (keysym == NoSymbol) {
  551.         Tcl_AppendResult(interp, "unknown keysym \"", value,
  552.             "\"", (char *) NULL);
  553.         return TCL_ERROR;
  554.         }
  555.         number = XKeysymToKeycode(event.xany.display, keysym);
  556.         if (number == 0) {
  557.         Tcl_AppendResult(interp, "no keycode for keysym \"", value,
  558.             "\"", (char *) NULL);
  559.         return TCL_ERROR;
  560.         }
  561.         event.xkey.keycode = number;
  562.     } else if (strcmp(field, "-mode") == 0) {
  563.         if (strcmp(value, "NotifyNormal") == 0) {
  564.         number = NotifyNormal;
  565.         } else if (strcmp(value, "NotifyGrab") == 0) {
  566.         number = NotifyGrab;
  567.         } else if (strcmp(value, "NotifyUngrab") == 0) {
  568.         number = NotifyUngrab;
  569.         } else if (strcmp(value, "NotifyWhileGrabbed") == 0) {
  570.         number = NotifyWhileGrabbed;
  571.         } else {
  572.         Tcl_AppendResult(interp, "bad mode \"", value, "\"",
  573.             (char *) NULL);
  574.         return TCL_ERROR;
  575.         }
  576.         if (flags & CROSSING) {
  577.         event.xcrossing.mode = number;
  578.         } else if (flags & FOCUS) {
  579.         event.xfocus.mode = number;
  580.         }
  581.     } else if (strcmp(field, "-override") == 0) {
  582.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  583.         return TCL_ERROR;
  584.         }
  585.         if (flags & CREATE) {
  586.         event.xcreatewindow.override_redirect = number;
  587.         } else if (flags & MAP) {
  588.         event.xmap.override_redirect = number;
  589.         } else if (flags & REPARENT) {
  590.         event.xreparent.override_redirect = number;
  591.         } else if (flags & CONFIG) {
  592.         event.xconfigure.override_redirect = number;
  593.         }
  594.     } else if (strcmp(field, "-place") == 0) {
  595.         if (strcmp(value, "PlaceOnTop") == 0) {
  596.         event.xcirculate.place = PlaceOnTop;
  597.         } else if (strcmp(value, "PlaceOnBottom") == 0) {
  598.         event.xcirculate.place = PlaceOnBottom;
  599.         } else if (strcmp(value, "bogus") == 0) {
  600.         event.xcirculate.place = 147;
  601.         } else {
  602.         Tcl_AppendResult(interp, "bad place \"", value, "\"",
  603.             (char *) NULL);
  604.         return TCL_ERROR;
  605.         }
  606.     } else if (strcmp(field, "-root") == 0) {
  607.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  608.         return TCL_ERROR;
  609.         }
  610.         event.xkey.root = number;
  611.     } else if (strcmp(field, "-rootx") == 0) {
  612.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  613.         return TCL_ERROR;
  614.         }
  615.         event.xkey.x_root = number;
  616.     } else if (strcmp(field, "-rooty") == 0) {
  617.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  618.         return TCL_ERROR;
  619.         }
  620.         event.xkey.y_root = number;
  621.     } else if (strcmp(field, "-sendevent") == 0) {
  622.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  623.         return TCL_ERROR;
  624.         }
  625.         event.xany.send_event = number;
  626.     } else if (strcmp(field, "-serial") == 0) {
  627.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  628.         return TCL_ERROR;
  629.         }
  630.         event.xany.serial = number;
  631.     } else if (strcmp(field, "-state") == 0) {
  632.         if (flags & KEY_BUTTON_MOTION) {
  633.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  634.             return TCL_ERROR;
  635.         }
  636.         event.xkey.state = number;
  637.         } else if (flags & CROSSING) {
  638.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  639.             return TCL_ERROR;
  640.         }
  641.         event.xcrossing.state = number;
  642.         } else if (flags & VISIBILITY) {
  643.         if (strcmp(value, "VisibilityUnobscured") == 0) {
  644.             number = VisibilityUnobscured;
  645.         } else if (strcmp(value, "VisibilityPartiallyObscured") == 0) {
  646.             number = VisibilityPartiallyObscured;
  647.         } else if (strcmp(value, "VisibilityFullyObscured") == 0) {
  648.             number = VisibilityFullyObscured;
  649.         } else {
  650.             Tcl_AppendResult(interp, "bad state \"", value, "\"",
  651.                 (char *) NULL);
  652.             return TCL_ERROR;
  653.         }
  654.         event.xvisibility.state = number;
  655.         }
  656.     } else if (strcmp(field, "-subwindow") == 0) {
  657.         tkwin2 = Tk_NameToWindow(interp, value, main);
  658.         if (tkwin2 == NULL) {
  659.         return TCL_ERROR;
  660.         }
  661.         event.xkey.subwindow = Tk_WindowId(tkwin2);
  662.     } else if (strcmp(field, "-time") == 0) {
  663.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  664.         return TCL_ERROR;
  665.         }
  666.         if (flags & (KEY_BUTTON_MOTION|PROP|SEL_CLEAR)) {
  667.         event.xkey.time = (Time) number;
  668.         } else if (flags & SEL_REQ) {
  669.         event.xselectionrequest.time = (Time) number;
  670.         } else if (flags & SEL_NOTIFY) {
  671.         event.xselection.time = (Time) number;
  672.         }
  673.     } else if (strcmp(field, "-valueMask") == 0) {
  674.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  675.         return TCL_ERROR;
  676.         }
  677.         event.xconfigurerequest.value_mask = number;
  678.     } else if (strcmp(field, "-width") == 0) {
  679.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  680.         return TCL_ERROR;
  681.         }
  682.         if (flags & EXPOSE) {
  683.         event.xexpose.width = number;
  684.         } else if (flags & (CONFIG|CONFIG_REQ)) {
  685.         event.xconfigure.width = number;
  686.         } else if (flags & RESIZE_REQ) {
  687.         event.xresizerequest.width = number;
  688.         }
  689.     } else if (strcmp(field, "-window") == 0) {
  690.         tkwin2 = Tk_NameToWindow(interp, value, main);
  691.         if (tkwin2 == NULL) {
  692.         return TCL_ERROR;
  693.         }
  694.         event.xmap.window = Tk_WindowId(tkwin2);
  695.     } else if (strcmp(field, "-x") == 0) {
  696.         int rootX, rootY;
  697.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  698.         return TCL_ERROR;
  699.         }
  700.         Tk_GetRootCoords(tkwin, &rootX, &rootY);
  701.         rootX += number;
  702.         if (flags & KEY_BUTTON_MOTION) {
  703.         event.xkey.x = number;
  704.         event.xkey.x_root = rootX;
  705.         } else if (flags & EXPOSE) {
  706.         event.xexpose.x = number;
  707.         } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) {
  708.         event.xcreatewindow.x = number;
  709.         } else if (flags & REPARENT) {
  710.         event.xreparent.x = number;
  711.         } else if (flags & CROSSING) {
  712.         event.xcrossing.x = number;
  713.         event.xcrossing.x_root = rootY;
  714.         }
  715.     } else if (strcmp(field, "-y") == 0) {
  716.         int rootX, rootY;
  717.         if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
  718.         return TCL_ERROR;
  719.         }
  720.         Tk_GetRootCoords(tkwin, &rootX, &rootY);
  721.         rootY += number;
  722.         if (flags & KEY_BUTTON_MOTION) {
  723.         event.xkey.y = number;
  724.         event.xkey.y_root = rootY;
  725.         } else if (flags & EXPOSE) {
  726.         event.xexpose.y = number;
  727.         } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) {
  728.         event.xcreatewindow.y = number;
  729.         } else if (flags & REPARENT) {
  730.         event.xreparent.y = number;
  731.         } else if (flags & CROSSING) {
  732.         event.xcrossing.y = number;
  733.         event.xcrossing.y_root = rootY;
  734.         }
  735.     } else {
  736.         Tcl_AppendResult(interp, "bad option \"", field, "\"",
  737.             (char *) NULL);
  738.         return TCL_ERROR;
  739.     }
  740.     }
  741.     Tk_HandleEvent(&event);
  742.     return TCL_OK;
  743. }
  744.  
  745. /*
  746.  *----------------------------------------------------------------------
  747.  *
  748.  * TestfeventCmd --
  749.  *
  750.  *    This procedure implements the "testfevent" command.  It is
  751.  *    used for testing the "fileevent" command and the Tk_EventInit
  752.  *    procedure.  It's also used for testing cleanup on interpreter
  753.  *    deletion.
  754.  *
  755.  * Results:
  756.  *    A standard Tcl result.
  757.  *
  758.  * Side effects:
  759.  *    Creates and deletes interpreters.
  760.  *
  761.  *----------------------------------------------------------------------
  762.  */
  763.  
  764.     /* ARGSUSED */
  765. static int
  766. TestfeventCmd(clientData, interp, argc, argv)
  767.     ClientData clientData;        /* Main window for application. */
  768.     Tcl_Interp *interp;            /* Current interpreter. */
  769.     int argc;                /* Number of arguments. */
  770.     char **argv;            /* Argument strings. */
  771. {
  772.     static Tcl_Interp *interp2 = NULL;
  773.     int code;
  774.  
  775.     if (argc < 2) {
  776.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  777.         " option ?arg arg ...?", (char *) NULL);
  778.     return TCL_ERROR;
  779.     }
  780.     if (strcmp(argv[1], "cmd") == 0) {
  781.     if (argc != 3) {
  782.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  783.             " cmd script", (char *) NULL);
  784.         return TCL_ERROR;
  785.     }
  786.     code = Tcl_GlobalEval(interp2, argv[2]);
  787.     interp->result = interp2->result;
  788.     return code;
  789.     } else if (strcmp(argv[1], "create") == 0) {
  790.     if (interp2 != NULL) {
  791.         Tcl_DeleteInterp(interp2);
  792.     }
  793.     interp2 = Tcl_CreateInterp();
  794.     Tk_EventInit(interp2);
  795.     return TCL_OK;
  796.     } else if (strcmp(argv[1], "delete") == 0) {
  797.     if (interp2 != NULL) {
  798.         Tcl_DeleteInterp(interp2);
  799.     }
  800.     interp2 = NULL;
  801.     }
  802.     return TCL_OK;
  803. }
  804.  
  805. /*
  806.  *----------------------------------------------------------------------
  807.  *
  808.  * TestmakeexistCmd --
  809.  *
  810.  *    This procedure implements the "testmakeexist" command.  It calls
  811.  *    Tk_MakeWindowExist on each of its arguments to force the windows
  812.  *    to be created.
  813.  *
  814.  * Results:
  815.  *    A standard Tcl result.
  816.  *
  817.  * Side effects:
  818.  *    Forces windows to be created.
  819.  *
  820.  *----------------------------------------------------------------------
  821.  */
  822.  
  823.     /* ARGSUSED */
  824. static int
  825. TestmakeexistCmd(clientData, interp, argc, argv)
  826.     ClientData clientData;        /* Main window for application. */
  827.     Tcl_Interp *interp;            /* Current interpreter. */
  828.     int argc;                /* Number of arguments. */
  829.     char **argv;            /* Argument strings. */
  830. {
  831.     Tk_Window main = (Tk_Window) clientData;
  832.     int i;
  833.     Tk_Window tkwin;
  834.  
  835.     for (i = 1; i < argc; i++) {
  836.     tkwin = Tk_NameToWindow(interp, argv[i], main);
  837.     if (tkwin == NULL) {
  838.         return TCL_ERROR;
  839.     }
  840.     Tk_MakeWindowExist(tkwin);
  841.     }
  842.  
  843.     return TCL_OK;
  844. }
  845.  
  846. /*
  847.  *----------------------------------------------------------------------
  848.  *
  849.  * ImageCreate --
  850.  *
  851.  *    This procedure is called by the Tk image code to create "test"
  852.  *    images.
  853.  *
  854.  * Results:
  855.  *    A standard Tcl result.
  856.  *
  857.  * Side effects:
  858.  *    The data structure for a new image is allocated.
  859.  *
  860.  *----------------------------------------------------------------------
  861.  */
  862.  
  863.     /* ARGSUSED */
  864. static int
  865. ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr)
  866.     Tcl_Interp *interp;        /* Interpreter for application containing
  867.                  * image. */
  868.     char *name;            /* Name to use for image. */
  869.     int argc;            /* Number of arguments. */
  870.     char **argv;        /* Argument strings for options (doesn't
  871.                  * include image name or type). */
  872.     Tk_ImageType *typePtr;    /* Pointer to our type record (not used). */
  873.     Tk_ImageMaster master;    /* Token for image, to be used by us in
  874.                  * later callbacks. */
  875.     ClientData *clientDataPtr;    /* Store manager's token for image here;
  876.                  * it will be returned in later callbacks. */
  877. {
  878.     TImageMaster *timPtr;
  879.     char *varName;
  880.     int i;
  881.  
  882.     varName = "log";
  883.     for (i = 0; i < argc; i += 2) {
  884.     if (strcmp(argv[i], "-variable") != 0) {
  885.         Tcl_AppendResult(interp, "bad option name \"", argv[i],
  886.             "\"", (char *) NULL);
  887.         return TCL_ERROR;
  888.     }
  889.     if ((i+1) == argc) {
  890.         Tcl_AppendResult(interp, "no value given for \"", argv[i],
  891.             "\" option", (char *) NULL);
  892.         return TCL_ERROR;
  893.     }
  894.     varName = argv[i+1];
  895.     }
  896.     timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster));
  897.     timPtr->master = master;
  898.     timPtr->interp = interp;
  899.     timPtr->width = 30;
  900.     timPtr->height = 15;
  901.     timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1));
  902.     strcpy(timPtr->imageName, name);
  903.     timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
  904.     strcpy(timPtr->varName, varName);
  905.     Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr,
  906.         (Tcl_CmdDeleteProc *) NULL);
  907.     *clientDataPtr = (ClientData) timPtr;
  908.     Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15);
  909.     return TCL_OK;
  910. }
  911.  
  912. /*
  913.  *----------------------------------------------------------------------
  914.  *
  915.  * ImageCmd --
  916.  *
  917.  *    This procedure implements the commands corresponding to individual
  918.  *    images. 
  919.  *
  920.  * Results:
  921.  *    A standard Tcl result.
  922.  *
  923.  * Side effects:
  924.  *    Forces windows to be created.
  925.  *
  926.  *----------------------------------------------------------------------
  927.  */
  928.  
  929.     /* ARGSUSED */
  930. static int
  931. ImageCmd(clientData, interp, argc, argv)
  932.     ClientData clientData;        /* Main window for application. */
  933.     Tcl_Interp *interp;            /* Current interpreter. */
  934.     int argc;                /* Number of arguments. */
  935.     char **argv;            /* Argument strings. */
  936. {
  937.     TImageMaster *timPtr = (TImageMaster *) clientData;
  938.     int x, y, width, height;
  939.  
  940.     if (argc < 2) {
  941.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  942.         argv[0], "option ?arg arg ...?", (char *) NULL);
  943.     return TCL_ERROR;
  944.     }
  945.     if (strcmp(argv[1], "changed") == 0) {
  946.     if (argc != 8) {
  947.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  948.             argv[0], " changed x y width height imageWidth imageHeight",
  949.             (char *) NULL);
  950.         return TCL_ERROR;
  951.     }
  952.     if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
  953.         || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)
  954.         || (Tcl_GetInt(interp, argv[4], &width) != TCL_OK)
  955.         || (Tcl_GetInt(interp, argv[5], &height) != TCL_OK)
  956.         || (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK)
  957.         || (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) {
  958.         return TCL_ERROR;
  959.     }
  960.     Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width,
  961.         timPtr->height);
  962.     } else {
  963.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  964.         "\": must be changed", (char *) NULL);
  965.     return TCL_ERROR;
  966.     }
  967.     return TCL_OK;
  968. }
  969.  
  970. /*
  971.  *----------------------------------------------------------------------
  972.  *
  973.  * ImageGet --
  974.  *
  975.  *    This procedure is called by Tk to set things up for using a
  976.  *    test image in a particular widget.
  977.  *
  978.  * Results:
  979.  *    The return value is a token for the image instance, which is
  980.  *    used in future callbacks to ImageDisplay and ImageFree.
  981.  *
  982.  * Side effects:
  983.  *    None.
  984.  *
  985.  *----------------------------------------------------------------------
  986.  */
  987.  
  988. static ClientData
  989. ImageGet(tkwin, clientData)
  990.     Tk_Window tkwin;        /* Token for window in which image will
  991.                  * be used. */
  992.     ClientData clientData;    /* Pointer to TImageMaster for image. */
  993. {
  994.     TImageMaster *timPtr = (TImageMaster *) clientData;
  995.     TImageInstance *instPtr;
  996.     char buffer[100];
  997.     XGCValues gcValues;
  998.  
  999.     sprintf(buffer, "%s get", timPtr->imageName);
  1000.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  1001.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  1002.  
  1003.     instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance));
  1004.     instPtr->masterPtr = timPtr;
  1005.     instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
  1006.     gcValues.foreground = instPtr->fg->pixel;
  1007.     instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
  1008.     return (ClientData) instPtr;
  1009. }
  1010.  
  1011. /*
  1012.  *----------------------------------------------------------------------
  1013.  *
  1014.  * ImageDisplay --
  1015.  *
  1016.  *    This procedure is invoked to redisplay part or all of an
  1017.  *    image in a given drawable.
  1018.  *
  1019.  * Results:
  1020.  *    None.
  1021.  *
  1022.  * Side effects:
  1023.  *    The image gets partially redrawn, as an "X" that shows the
  1024.  *    exact redraw area.
  1025.  *
  1026.  *----------------------------------------------------------------------
  1027.  */
  1028.  
  1029. static void
  1030. ImageDisplay(clientData, display, drawable, imageX, imageY, width, height,
  1031.     drawableX, drawableY)
  1032.     ClientData clientData;    /* Pointer to TImageInstance for image. */
  1033.     Display *display;        /* Display to use for drawing. */
  1034.     Drawable drawable;        /* Where to redraw image. */
  1035.     int imageX, imageY;        /* Origin of area to redraw, relative to
  1036.                  * origin of image. */
  1037.     int width, height;        /* Dimensions of area to redraw. */
  1038.     int drawableX, drawableY;    /* Coordinates in drawable corresponding to
  1039.                  * imageX and imageY. */
  1040. {
  1041.     TImageInstance *instPtr = (TImageInstance *) clientData;
  1042.     char buffer[200];
  1043.  
  1044.     sprintf(buffer, "%s display %d %d %d %d %d %d",
  1045.         instPtr->masterPtr->imageName, imageX, imageY, width, height,
  1046.         drawableX, drawableY);
  1047.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  1048.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  1049.     if (width > (instPtr->masterPtr->width - imageX)) {
  1050.     width = instPtr->masterPtr->width - imageX;
  1051.     }
  1052.     if (height > (instPtr->masterPtr->height - imageY)) {
  1053.     height = instPtr->masterPtr->height - imageY;
  1054.     }
  1055.     XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY,
  1056.         (unsigned) (width-1), (unsigned) (height-1));
  1057.     XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY,
  1058.         (int) (drawableX + width - 1), (int) (drawableY + height - 1));
  1059.     XDrawLine(display, drawable, instPtr->gc, drawableX,
  1060.         (int) (drawableY + height - 1),
  1061.         (int) (drawableX + width - 1), drawableY);
  1062. }
  1063.  
  1064. /*
  1065.  *----------------------------------------------------------------------
  1066.  *
  1067.  * ImageFree --
  1068.  *
  1069.  *    This procedure is called when an instance of an image is
  1070.  *     no longer used.
  1071.  *
  1072.  * Results:
  1073.  *    None.
  1074.  *
  1075.  * Side effects:
  1076.  *    Information related to the instance is freed.
  1077.  *
  1078.  *----------------------------------------------------------------------
  1079.  */
  1080.  
  1081. static void
  1082. ImageFree(clientData, display)
  1083.     ClientData clientData;    /* Pointer to TImageInstance for instance. */
  1084.     Display *display;        /* Display where image was to be drawn. */
  1085. {
  1086.     TImageInstance *instPtr = (TImageInstance *) clientData;
  1087.     char buffer[200];
  1088.  
  1089.     sprintf(buffer, "%s free", instPtr->masterPtr->imageName);
  1090.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  1091.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  1092.     Tk_FreeColor(instPtr->fg);
  1093.     Tk_FreeGC(display, instPtr->gc);
  1094.     ckfree((char *) instPtr);
  1095. }
  1096.  
  1097. /*
  1098.  *----------------------------------------------------------------------
  1099.  *
  1100.  * ImageDelete --
  1101.  *
  1102.  *    This procedure is called to clean up a test image when
  1103.  *    an application goes away.
  1104.  *
  1105.  * Results:
  1106.  *    None.
  1107.  *
  1108.  * Side effects:
  1109.  *    Information about the image is deleted.
  1110.  *
  1111.  *----------------------------------------------------------------------
  1112.  */
  1113.  
  1114. static void
  1115. ImageDelete(clientData)
  1116.     ClientData clientData;    /* Pointer to TImageMaster for image.  When
  1117.                  * this procedure is called, no more
  1118.                  * instances exist. */
  1119. {
  1120.     TImageMaster *timPtr = (TImageMaster *) clientData;
  1121.     char buffer[100];
  1122.  
  1123.     sprintf(buffer, "%s delete", timPtr->imageName);
  1124.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  1125.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  1126.  
  1127.     Tcl_DeleteCommand(timPtr->interp, timPtr->imageName);
  1128.     ckfree(timPtr->imageName);
  1129.     ckfree(timPtr->varName);
  1130.     ckfree((char *) timPtr);
  1131. }
  1132.  
  1133. /*
  1134.  *----------------------------------------------------------------------
  1135.  *
  1136.  * TestnewappCmd --
  1137.  *
  1138.  *    This procedure implements the "testnewapp" command.  It will
  1139.  *    create a new Tk application in the same process.
  1140.  *
  1141.  * Results:
  1142.  *    A standard Tcl result.
  1143.  *
  1144.  * Side effects:
  1145.  *    Depends on option;  see below.
  1146.  *
  1147.  *----------------------------------------------------------------------
  1148.  */
  1149.  
  1150.     /* ARGSUSED */
  1151. static int
  1152. TestnewappCmd(clientData, interp, argc, argv)
  1153.     ClientData clientData;        /* Main window for application. */
  1154.     Tcl_Interp *interp;            /* Current interpreter. */
  1155.     int argc;                /* Number of arguments. */
  1156.     char **argv;            /* Argument strings. */
  1157. {
  1158.     Tcl_Interp *newInterp;
  1159.     Tk_Window tkwin;
  1160.     NewApp *appPtr;
  1161.  
  1162.     if (argc != 4) {
  1163.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1164.         " screen name class\"", (char *) NULL);
  1165.     return TCL_ERROR;
  1166.     }
  1167.  
  1168.     newInterp = Tcl_CreateInterp();
  1169.     tkwin = Tk_CreateMainWindow(newInterp, argv[1], argv[2], argv[3]);
  1170.     if (tkwin == NULL) {
  1171.     goto error;
  1172.     }
  1173.     if (Tcl_Init(newInterp) != TCL_OK) {
  1174.     goto error;
  1175.     }
  1176.     if (Tk_Init(newInterp) != TCL_OK) {
  1177.     goto error;
  1178.     }
  1179.     appPtr = (NewApp *) ckalloc(sizeof(NewApp));
  1180.     appPtr->interp = newInterp;
  1181.     appPtr->nextPtr = newAppPtr;
  1182.     newAppPtr = appPtr;
  1183.     return TCL_OK;
  1184.  
  1185.     error:
  1186.     Tcl_SetResult(interp, newInterp->result, TCL_VOLATILE);
  1187.     if (tkwin != NULL) {
  1188.     Tk_DestroyWindow(tkwin);
  1189.     }
  1190.     Tcl_DeleteInterp(newInterp);
  1191.     return TCL_ERROR;
  1192. }
  1193.  
  1194. /*
  1195.  *----------------------------------------------------------------------
  1196.  *
  1197.  * TestsendCmd --
  1198.  *
  1199.  *    This procedure implements the "testsend" command.  It provides
  1200.  *    a set of functions for testing the "send" command and support
  1201.  *    procedure in tkSend.c.
  1202.  *
  1203.  * Results:
  1204.  *    A standard Tcl result.
  1205.  *
  1206.  * Side effects:
  1207.  *    Depends on option;  see below.
  1208.  *
  1209.  *----------------------------------------------------------------------
  1210.  */
  1211.  
  1212.     /* ARGSUSED */
  1213. static int
  1214. TestsendCmd(clientData, interp, argc, argv)
  1215.     ClientData clientData;        /* Main window for application. */
  1216.     Tcl_Interp *interp;            /* Current interpreter. */
  1217.     int argc;                /* Number of arguments. */
  1218.     char **argv;            /* Argument strings. */
  1219. {
  1220.     TkWindow *winPtr = (TkWindow *) clientData;
  1221.  
  1222.     if (argc < 2) {
  1223.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1224.         " option ?arg ...?\"", (char *) NULL);
  1225.     return TCL_ERROR;
  1226.     }
  1227.  
  1228.     if (strcmp(argv[1], "bogus") == 0) {
  1229.     XChangeProperty(winPtr->dispPtr->display,
  1230.         RootWindow(winPtr->dispPtr->display, 0),
  1231.         winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
  1232.         PropModeReplace,
  1233.         (unsigned char *) "This is bogus information", 6);
  1234.     } else if (strcmp(argv[1], "prop") == 0) {
  1235.     int result, actualFormat, length;
  1236.     unsigned long bytesAfter;
  1237.     Atom actualType, propName;
  1238.     char *property, *p, *end;
  1239.     Window w;
  1240.  
  1241.     if ((argc != 4) && (argc != 5)) {
  1242.         Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1243.             " prop window name ?value ?\"", (char *) NULL);
  1244.         return TCL_ERROR;
  1245.     }
  1246.     if (strcmp(argv[2], "root") == 0) {
  1247.         w = RootWindow(winPtr->dispPtr->display, 0);
  1248.     } else if (strcmp(argv[2], "comm") == 0) {
  1249.         w = Tk_WindowId(winPtr->dispPtr->commTkwin);
  1250.     } else {
  1251.         w = strtoul(argv[2], &end, 0);
  1252.     }
  1253.     propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]);
  1254.     if (argc == 4) {
  1255.         property = NULL;
  1256.         result = XGetWindowProperty(winPtr->dispPtr->display,
  1257.             w, propName, 0, 100000, False, XA_STRING,
  1258.             &actualType, &actualFormat, (unsigned long *) &length,
  1259.             &bytesAfter, (unsigned char **) &property);
  1260.         if ((result == Success) && (actualType != None)
  1261.             && (actualFormat == 8) && (actualType == XA_STRING)) {
  1262.         for (p = property; (p-property) < length; p++) {
  1263.             if (*p == 0) {
  1264.             *p = '\n';
  1265.             }
  1266.         }
  1267.         Tcl_SetResult(interp, property, TCL_VOLATILE);
  1268.         }
  1269.         if (property != NULL) {
  1270.         XFree(property);
  1271.         }
  1272.     } else {
  1273.         if (argv[4][0] == 0) {
  1274.         XDeleteProperty(winPtr->dispPtr->display, w, propName);
  1275.         } else {
  1276.         for (p = argv[4]; *p != 0; p++) {
  1277.             if (*p == '\n') {
  1278.             *p = 0;
  1279.             }
  1280.         }
  1281.         XChangeProperty(winPtr->dispPtr->display,
  1282.             w, propName, XA_STRING, 8, PropModeReplace,
  1283.             (unsigned char *) argv[4], p-argv[4]);
  1284.         }
  1285.     }
  1286.     } else if (strcmp(argv[1], "serial") == 0) {
  1287.     sprintf(interp->result, "%d", tkSendSerial+1);
  1288.     } else {
  1289.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1290.         "\": must be bogus, prop, or serial", (char *) NULL);
  1291.     return TCL_ERROR;
  1292.     }
  1293.     return TCL_OK;
  1294. }
  1295.