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