home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcltk805.zip / tcl805s.zip / tk8.0.5 / os2 / tkTest.c < prev    next >
C/C++ Source or Header  |  2000-01-01  |  34KB  |  1,191 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-1997 Sun Microsystems, Inc.
  11.  * Copyright (c) 1999-2000 Illya Vaes.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  *
  16.  * RCS: @(#) $Id: tkTest.c,v 1.4 1999/02/04 20:57:17 stanton Exp $
  17.  */
  18.  
  19. #include "tkInt.h"
  20. #include "tkPort.h"    
  21.  
  22. #ifdef __WIN32__
  23. #include "tkWinInt.h"
  24. #endif
  25.  
  26. #ifdef MAC_TCL
  27. #include "tkScrollbar.h"
  28. #endif
  29.  
  30. #ifdef __OS2__
  31. #include "tkOS2Int.h"
  32. #endif
  33.  
  34. #ifdef __UNIX__
  35. #include "tkUnixInt.h"
  36. #endif
  37.  
  38. /*
  39.  * The following data structure represents the master for a test
  40.  * image:
  41.  */
  42.  
  43. typedef struct TImageMaster {
  44.     Tk_ImageMaster master;    /* Tk's token for image master. */
  45.     Tcl_Interp *interp;        /* Interpreter for application. */
  46.     int width, height;        /* Dimensions of image. */
  47.     char *imageName;        /* Name of image (malloc-ed). */
  48.     char *varName;        /* Name of variable in which to log
  49.                  * events for image (malloc-ed). */
  50. } TImageMaster;
  51.  
  52. /*
  53.  * The following data structure represents a particular use of a
  54.  * particular test image.
  55.  */
  56.  
  57. typedef struct TImageInstance {
  58.     TImageMaster *masterPtr;    /* Pointer to master for image. */
  59.     XColor *fg;            /* Foreground color for drawing in image. */
  60.     GC gc;            /* Graphics context for drawing in image. */
  61. } TImageInstance;
  62.  
  63. /*
  64.  * The type record for test images:
  65.  */
  66.  
  67. static int        ImageCreate _ANSI_ARGS_((Tcl_Interp *interp,
  68.                 char *name, int argc, char **argv,
  69.                 Tk_ImageType *typePtr, Tk_ImageMaster master,
  70.                 ClientData *clientDataPtr));
  71. static ClientData    ImageGet _ANSI_ARGS_((Tk_Window tkwin,
  72.                 ClientData clientData));
  73. static void        ImageDisplay _ANSI_ARGS_((ClientData clientData,
  74.                 Display *display, Drawable drawable, 
  75.                 int imageX, int imageY, int width,
  76.                 int height, int drawableX,
  77.                 int drawableY));
  78. static void        ImageFree _ANSI_ARGS_((ClientData clientData,
  79.                 Display *display));
  80. static void        ImageDelete _ANSI_ARGS_((ClientData clientData));
  81.  
  82. static Tk_ImageType imageType = {
  83.     "test",            /* name */
  84.     ImageCreate,        /* createProc */
  85.     ImageGet,            /* getProc */
  86.     ImageDisplay,        /* displayProc */
  87.     ImageFree,            /* freeProc */
  88.     ImageDelete,        /* deleteProc */
  89.     (Tk_ImageType *) NULL    /* nextPtr */
  90. };
  91.  
  92. /*
  93.  * One of the following structures describes each of the interpreters
  94.  * created by the "testnewapp" command.  This information is used by
  95.  * the "testdeleteinterps" command to destroy all of those interpreters.
  96.  */
  97.  
  98. typedef struct NewApp {
  99.     Tcl_Interp *interp;        /* Token for interpreter. */
  100.     struct NewApp *nextPtr;    /* Next in list of new interpreters. */
  101. } NewApp;
  102.  
  103. static NewApp *newAppPtr = NULL;
  104.                 /* First in list of all new interpreters. */
  105.  
  106. /*
  107.  * Declaration for the square widget's class command procedure:
  108.  */
  109.  
  110. extern int SquareCmd _ANSI_ARGS_((ClientData clientData,
  111.     Tcl_Interp *interp, int argc, char *argv[]));
  112.  
  113. typedef struct CBinding {
  114.     Tcl_Interp *interp;
  115.     char *command;
  116.     char *delete;
  117. } CBinding;
  118.  
  119. /*
  120.  * Forward declarations for procedures defined later in this file:
  121.  */
  122.  
  123. static int        CBindingEvalProc _ANSI_ARGS_((ClientData clientData, 
  124.                 Tcl_Interp *interp, XEvent *eventPtr,
  125.                 Tk_Window tkwin, KeySym keySym));
  126. static void        CBindingFreeProc _ANSI_ARGS_((ClientData clientData));
  127. int            Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
  128. static int        ImageCmd _ANSI_ARGS_((ClientData dummy,
  129.                 Tcl_Interp *interp, int argc, char **argv));
  130. static int        TestcbindCmd _ANSI_ARGS_((ClientData dummy,
  131.                 Tcl_Interp *interp, int argc, char **argv));
  132. #if (defined(__WIN32__) || defined(__OS2__))
  133. static int        TestclipboardCmd _ANSI_ARGS_((ClientData dummy,
  134.                 Tcl_Interp *interp, int argc, char **argv));
  135. #endif
  136. static int        TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy,
  137.                 Tcl_Interp *interp, int argc, char **argv));
  138. static int        TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
  139.                 Tcl_Interp *interp, int argc, char **argv));
  140. static int        TestmenubarCmd _ANSI_ARGS_((ClientData dummy,
  141.                 Tcl_Interp *interp, int argc, char **argv));
  142. #if defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__)
  143. static int        TestmetricsCmd _ANSI_ARGS_((ClientData dummy,
  144.                 Tcl_Interp *interp, int argc, char **argv));
  145. #endif
  146. static int        TestsendCmd _ANSI_ARGS_((ClientData dummy,
  147.                 Tcl_Interp *interp, int argc, char **argv));
  148. static int        TestpropCmd _ANSI_ARGS_((ClientData dummy,
  149.                 Tcl_Interp *interp, int argc, char **argv));
  150. #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__))
  151. static int        TestwrapperCmd _ANSI_ARGS_((ClientData dummy,
  152.                 Tcl_Interp *interp, int argc, char **argv));
  153. #endif
  154.  
  155. /*
  156.  * External (platform specific) initialization routine:
  157.  */
  158.  
  159. extern int        TkplatformtestInit _ANSI_ARGS_((
  160.                 Tcl_Interp *interp));
  161. #ifndef MAC_TCL
  162. #define TkplatformtestInit(x) TCL_OK
  163. #endif
  164.  
  165. /*
  166.  *----------------------------------------------------------------------
  167.  *
  168.  * Tktest_Init --
  169.  *
  170.  *    This procedure performs intialization for the Tk test
  171.  *    suite exensions.
  172.  *
  173.  * Results:
  174.  *    Returns a standard Tcl completion code, and leaves an error
  175.  *    message in interp->result if an error occurs.
  176.  *
  177.  * Side effects:
  178.  *    Creates several test commands.
  179.  *
  180.  *----------------------------------------------------------------------
  181.  */
  182.  
  183. int
  184. Tktest_Init(interp)
  185.     Tcl_Interp *interp;        /* Interpreter for application. */
  186. {
  187.     static int initialized = 0;
  188.  
  189.     /*
  190.      * Create additional commands for testing Tk.
  191.      */
  192.  
  193.     if (Tcl_PkgProvide(interp, "Tktest", TK_VERSION) == TCL_ERROR) {
  194.         return TCL_ERROR;
  195.     }
  196.  
  197.     Tcl_CreateCommand(interp, "square", SquareCmd,
  198.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  199. #if (defined(__WIN32__) || defined(__OS2__))
  200.     Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd,
  201.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  202. #endif
  203.     Tcl_CreateCommand(interp, "testcbind", TestcbindCmd,
  204.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  205.     Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd,
  206.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  207.     Tcl_CreateCommand(interp, "testembed", TkpTestembedCmd,
  208.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  209.     Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
  210.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  211.     Tcl_CreateCommand(interp, "testmenubar", TestmenubarCmd,
  212.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  213. #if defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__)
  214.     Tcl_CreateCommand(interp, "testmetrics", TestmetricsCmd,
  215.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  216. #endif
  217.     Tcl_CreateCommand(interp, "testprop", TestpropCmd,
  218.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  219.     Tcl_CreateCommand(interp, "testsend", TestsendCmd,
  220.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  221. #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__))
  222.     Tcl_CreateCommand(interp, "testwrapper", TestwrapperCmd,
  223.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  224. #endif
  225.  
  226.     /*
  227.      * Create test image type.
  228.      */
  229.  
  230.     if (!initialized) {
  231.     initialized = 1;
  232.     Tk_CreateImageType(&imageType);
  233.     }
  234.  
  235.     /*
  236.      * And finally add any platform specific test commands.
  237.      */
  238.     
  239.     return TkplatformtestInit(interp);
  240. }
  241.  
  242. /*
  243.  *----------------------------------------------------------------------
  244.  *
  245.  * TestclipboardCmd --
  246.  *
  247.  *    This procedure implements the testclipboard command. It provides
  248.  *    a way to determine the actual contents of the Windows / OS/2
  249.  *      clipboard.
  250.  *
  251.  * Results:
  252.  *    A standard Tcl result.
  253.  *
  254.  * Side effects:
  255.  *    None.
  256.  *
  257.  *----------------------------------------------------------------------
  258.  */
  259.  
  260. #ifdef __WIN32__
  261. static int
  262. TestclipboardCmd(clientData, interp, argc, argv)
  263.     ClientData clientData;        /* Main window for application. */
  264.     Tcl_Interp *interp;            /* Current interpreter. */
  265.     int argc;                /* Number of arguments. */
  266.     char **argv;            /* Argument strings. */
  267. {
  268.     TkWindow *winPtr = (TkWindow *) clientData;
  269.     HGLOBAL handle;
  270.     char *data;
  271.  
  272.     if (OpenClipboard(NULL)) {
  273.     handle = GetClipboardData(CF_TEXT);
  274.     if (handle != NULL) {
  275.         data = GlobalLock(handle);
  276.         Tcl_AppendResult(interp, data, (char *) NULL);
  277.         GlobalUnlock(handle);
  278.     }
  279.     CloseClipboard();
  280.     }
  281.     return TCL_OK;
  282. }
  283. #endif
  284. #ifdef __OS2__
  285. static int
  286. TestclipboardCmd(clientData, interp, argc, argv)
  287.     ClientData clientData;              /* Main window for application. */
  288.     Tcl_Interp *interp;                 /* Current interpreter. */
  289.     int argc;                           /* Number of arguments. */
  290.     char **argv;                        /* Argument strings. */
  291. {
  292.     char *data;
  293.     HAB hab = TclOS2GetHAB();
  294.  
  295.     if (WinOpenClipbrd(hab)) {
  296.         if ((data= (char *)WinQueryClipbrdData(hab, CF_TEXT))) {
  297.             Tcl_AppendResult(interp, data, (char *) NULL);
  298.         }
  299.         WinCloseClipbrd(hab);
  300.     }
  301.     return TCL_OK;
  302. }
  303. #endif
  304.  
  305. /*
  306.  *----------------------------------------------------------------------
  307.  *
  308.  * TestcbindCmd --
  309.  *
  310.  *    This procedure implements the "testcbinding" command.  It provides
  311.  *    a set of functions for testing C bindings in tkBind.c.
  312.  *
  313.  * Results:
  314.  *    A standard Tcl result.
  315.  *
  316.  * Side effects:
  317.  *    Depends on option;  see below.
  318.  *
  319.  *----------------------------------------------------------------------
  320.  */
  321.  
  322. static int
  323. TestcbindCmd(clientData, interp, argc, argv)
  324.     ClientData clientData;        /* Main window for application. */
  325.     Tcl_Interp *interp;            /* Current interpreter. */
  326.     int argc;                /* Number of arguments. */
  327.     char **argv;            /* Argument strings. */
  328. {
  329.     TkWindow *winPtr;
  330.     Tk_Window tkwin;
  331.     ClientData object;
  332.     CBinding *cbindPtr;
  333.     
  334.     
  335.     if (argc < 4 || argc > 5) {
  336.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  337.         " bindtag pattern command ?deletecommand?", (char *) NULL);
  338.     return TCL_ERROR;
  339.     }
  340.  
  341.     tkwin = (Tk_Window) clientData;
  342.  
  343.     if (argv[1][0] == '.') {
  344.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
  345.     if (winPtr == NULL) {
  346.         return TCL_ERROR;
  347.     }
  348.     object = (ClientData) winPtr->pathName;
  349.     } else {
  350.     winPtr = (TkWindow *) clientData;
  351.     object = (ClientData) Tk_GetUid(argv[1]);
  352.     }
  353.  
  354.     if (argv[3][0] == '\0') {
  355.     return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable,
  356.         object, argv[2]);
  357.     }
  358.  
  359.     cbindPtr = (CBinding *) ckalloc(sizeof(CBinding));
  360.     cbindPtr->interp = interp;
  361.     cbindPtr->command =
  362.         strcpy((char *) ckalloc(strlen(argv[3]) + 1), argv[3]);
  363.     if (argc == 4) {
  364.     cbindPtr->delete = NULL;
  365.     } else {
  366.     cbindPtr->delete =
  367.         strcpy((char *) ckalloc(strlen(argv[4]) + 1), argv[4]);
  368.     }
  369.  
  370.     if (TkCreateBindingProcedure(interp, winPtr->mainPtr->bindingTable,
  371.         object, argv[2], CBindingEvalProc, CBindingFreeProc,
  372.         (ClientData) cbindPtr) == 0) {
  373.     ckfree((char *) cbindPtr->command);
  374.     if (cbindPtr->delete != NULL) {
  375.         ckfree((char *) cbindPtr->delete);
  376.     }
  377.     ckfree((char *) cbindPtr);
  378.     return TCL_ERROR;
  379.     }
  380.     return TCL_OK;
  381. }
  382.  
  383. static int
  384. CBindingEvalProc(clientData, interp, eventPtr, tkwin, keySym)
  385.     ClientData clientData;
  386.     Tcl_Interp *interp;
  387.     XEvent *eventPtr;
  388.     Tk_Window tkwin;
  389.     KeySym keySym;
  390. {
  391.     CBinding *cbindPtr;
  392.  
  393.     cbindPtr = (CBinding *) clientData;
  394.     
  395.     return Tcl_GlobalEval(interp, cbindPtr->command);
  396. }
  397.  
  398. static void
  399. CBindingFreeProc(clientData)
  400.     ClientData clientData;
  401. {
  402.     CBinding *cbindPtr = (CBinding *) clientData;
  403.     
  404.     if (cbindPtr->delete != NULL) {
  405.     Tcl_GlobalEval(cbindPtr->interp, cbindPtr->delete);
  406.     ckfree((char *) cbindPtr->delete);
  407.     }
  408.     ckfree((char *) cbindPtr->command);
  409.     ckfree((char *) cbindPtr);
  410. }
  411.  
  412. /*
  413.  *----------------------------------------------------------------------
  414.  *
  415.  * TestdeleteappsCmd --
  416.  *
  417.  *    This procedure implements the "testdeleteapps" command.  It cleans
  418.  *    up all the interpreters left behind by the "testnewapp" command.
  419.  *
  420.  * Results:
  421.  *    A standard Tcl result.
  422.  *
  423.  * Side effects:
  424.  *    All the intepreters created by previous calls to "testnewapp"
  425.  *    get deleted.
  426.  *
  427.  *----------------------------------------------------------------------
  428.  */
  429.  
  430.     /* ARGSUSED */
  431. static int
  432. TestdeleteappsCmd(clientData, interp, argc, argv)
  433.     ClientData clientData;        /* Main window for application. */
  434.     Tcl_Interp *interp;            /* Current interpreter. */
  435.     int argc;                /* Number of arguments. */
  436.     char **argv;            /* Argument strings. */
  437. {
  438.     NewApp *nextPtr;
  439.  
  440.     while (newAppPtr != NULL) {
  441.     nextPtr = newAppPtr->nextPtr;
  442.     Tcl_DeleteInterp(newAppPtr->interp);
  443.     ckfree((char *) newAppPtr);
  444.     newAppPtr = nextPtr;
  445.     }
  446.  
  447.     return TCL_OK;
  448. }
  449.  
  450. /*
  451.  *----------------------------------------------------------------------
  452.  *
  453.  * ImageCreate --
  454.  *
  455.  *    This procedure is called by the Tk image code to create "test"
  456.  *    images.
  457.  *
  458.  * Results:
  459.  *    A standard Tcl result.
  460.  *
  461.  * Side effects:
  462.  *    The data structure for a new image is allocated.
  463.  *
  464.  *----------------------------------------------------------------------
  465.  */
  466.  
  467.     /* ARGSUSED */
  468. static int
  469. ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr)
  470.     Tcl_Interp *interp;        /* Interpreter for application containing
  471.                  * image. */
  472.     char *name;            /* Name to use for image. */
  473.     int argc;            /* Number of arguments. */
  474.     char **argv;        /* Argument strings for options (doesn't
  475.                  * include image name or type). */
  476.     Tk_ImageType *typePtr;    /* Pointer to our type record (not used). */
  477.     Tk_ImageMaster master;    /* Token for image, to be used by us in
  478.                  * later callbacks. */
  479.     ClientData *clientDataPtr;    /* Store manager's token for image here;
  480.                  * it will be returned in later callbacks. */
  481. {
  482.     TImageMaster *timPtr;
  483.     char *varName;
  484.     int i;
  485.  
  486.     varName = "log";
  487.     for (i = 0; i < argc; i += 2) {
  488.     if (strcmp(argv[i], "-variable") != 0) {
  489.         Tcl_AppendResult(interp, "bad option name \"", argv[i],
  490.             "\"", (char *) NULL);
  491.         return TCL_ERROR;
  492.     }
  493.     if ((i+1) == argc) {
  494.         Tcl_AppendResult(interp, "no value given for \"", argv[i],
  495.             "\" option", (char *) NULL);
  496.         return TCL_ERROR;
  497.     }
  498.     varName = argv[i+1];
  499.     }
  500.     timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster));
  501.     timPtr->master = master;
  502.     timPtr->interp = interp;
  503.     timPtr->width = 30;
  504.     timPtr->height = 15;
  505.     timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1));
  506.     strcpy(timPtr->imageName, name);
  507.     timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
  508.     strcpy(timPtr->varName, varName);
  509.     Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr,
  510.         (Tcl_CmdDeleteProc *) NULL);
  511.     *clientDataPtr = (ClientData) timPtr;
  512.     Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15);
  513.     return TCL_OK;
  514. }
  515.  
  516. /*
  517.  *----------------------------------------------------------------------
  518.  *
  519.  * ImageCmd --
  520.  *
  521.  *    This procedure implements the commands corresponding to individual
  522.  *    images. 
  523.  *
  524.  * Results:
  525.  *    A standard Tcl result.
  526.  *
  527.  * Side effects:
  528.  *    Forces windows to be created.
  529.  *
  530.  *----------------------------------------------------------------------
  531.  */
  532.  
  533.     /* ARGSUSED */
  534. static int
  535. ImageCmd(clientData, interp, argc, argv)
  536.     ClientData clientData;        /* Main window for application. */
  537.     Tcl_Interp *interp;            /* Current interpreter. */
  538.     int argc;                /* Number of arguments. */
  539.     char **argv;            /* Argument strings. */
  540. {
  541.     TImageMaster *timPtr = (TImageMaster *) clientData;
  542.     int x, y, width, height;
  543.  
  544.     if (argc < 2) {
  545.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  546.         argv[0], "option ?arg arg ...?", (char *) NULL);
  547.     return TCL_ERROR;
  548.     }
  549.     if (strcmp(argv[1], "changed") == 0) {
  550.     if (argc != 8) {
  551.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  552.             argv[0], " changed x y width height imageWidth imageHeight",
  553.             (char *) NULL);
  554.         return TCL_ERROR;
  555.     }
  556.     if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
  557.         || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)
  558.         || (Tcl_GetInt(interp, argv[4], &width) != TCL_OK)
  559.         || (Tcl_GetInt(interp, argv[5], &height) != TCL_OK)
  560.         || (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK)
  561.         || (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) {
  562.         return TCL_ERROR;
  563.     }
  564.     Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width,
  565.         timPtr->height);
  566.     } else {
  567.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  568.         "\": must be changed", (char *) NULL);
  569.     return TCL_ERROR;
  570.     }
  571.     return TCL_OK;
  572. }
  573.  
  574. /*
  575.  *----------------------------------------------------------------------
  576.  *
  577.  * ImageGet --
  578.  *
  579.  *    This procedure is called by Tk to set things up for using a
  580.  *    test image in a particular widget.
  581.  *
  582.  * Results:
  583.  *    The return value is a token for the image instance, which is
  584.  *    used in future callbacks to ImageDisplay and ImageFree.
  585.  *
  586.  * Side effects:
  587.  *    None.
  588.  *
  589.  *----------------------------------------------------------------------
  590.  */
  591.  
  592. static ClientData
  593. ImageGet(tkwin, clientData)
  594.     Tk_Window tkwin;        /* Token for window in which image will
  595.                  * be used. */
  596.     ClientData clientData;    /* Pointer to TImageMaster for image. */
  597. {
  598.     TImageMaster *timPtr = (TImageMaster *) clientData;
  599.     TImageInstance *instPtr;
  600.     char buffer[100];
  601.     XGCValues gcValues;
  602.  
  603.     sprintf(buffer, "%s get", timPtr->imageName);
  604.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  605.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  606.  
  607.     instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance));
  608.     instPtr->masterPtr = timPtr;
  609.     instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
  610.     gcValues.foreground = instPtr->fg->pixel;
  611.     instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
  612.     return (ClientData) instPtr;
  613. }
  614.  
  615. /*
  616.  *----------------------------------------------------------------------
  617.  *
  618.  * ImageDisplay --
  619.  *
  620.  *    This procedure is invoked to redisplay part or all of an
  621.  *    image in a given drawable.
  622.  *
  623.  * Results:
  624.  *    None.
  625.  *
  626.  * Side effects:
  627.  *    The image gets partially redrawn, as an "X" that shows the
  628.  *    exact redraw area.
  629.  *
  630.  *----------------------------------------------------------------------
  631.  */
  632.  
  633. static void
  634. ImageDisplay(clientData, display, drawable, imageX, imageY, width, height,
  635.     drawableX, drawableY)
  636.     ClientData clientData;    /* Pointer to TImageInstance for image. */
  637.     Display *display;        /* Display to use for drawing. */
  638.     Drawable drawable;        /* Where to redraw image. */
  639.     int imageX, imageY;        /* Origin of area to redraw, relative to
  640.                  * origin of image. */
  641.     int width, height;        /* Dimensions of area to redraw. */
  642.     int drawableX, drawableY;    /* Coordinates in drawable corresponding to
  643.                  * imageX and imageY. */
  644. {
  645.     TImageInstance *instPtr = (TImageInstance *) clientData;
  646.     char buffer[200];
  647.  
  648.     sprintf(buffer, "%s display %d %d %d %d %d %d",
  649.         instPtr->masterPtr->imageName, imageX, imageY, width, height,
  650.         drawableX, drawableY);
  651.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  652.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  653.     if (width > (instPtr->masterPtr->width - imageX)) {
  654.     width = instPtr->masterPtr->width - imageX;
  655.     }
  656.     if (height > (instPtr->masterPtr->height - imageY)) {
  657.     height = instPtr->masterPtr->height - imageY;
  658.     }
  659.     XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY,
  660.         (unsigned) (width-1), (unsigned) (height-1));
  661.     XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY,
  662.         (int) (drawableX + width - 1), (int) (drawableY + height - 1));
  663.     XDrawLine(display, drawable, instPtr->gc, drawableX,
  664.         (int) (drawableY + height - 1),
  665.         (int) (drawableX + width - 1), drawableY);
  666. }
  667.  
  668. /*
  669.  *----------------------------------------------------------------------
  670.  *
  671.  * ImageFree --
  672.  *
  673.  *    This procedure is called when an instance of an image is
  674.  *     no longer used.
  675.  *
  676.  * Results:
  677.  *    None.
  678.  *
  679.  * Side effects:
  680.  *    Information related to the instance is freed.
  681.  *
  682.  *----------------------------------------------------------------------
  683.  */
  684.  
  685. static void
  686. ImageFree(clientData, display)
  687.     ClientData clientData;    /* Pointer to TImageInstance for instance. */
  688.     Display *display;        /* Display where image was to be drawn. */
  689. {
  690.     TImageInstance *instPtr = (TImageInstance *) clientData;
  691.     char buffer[200];
  692.  
  693.     sprintf(buffer, "%s free", instPtr->masterPtr->imageName);
  694.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  695.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  696.     Tk_FreeColor(instPtr->fg);
  697.     Tk_FreeGC(display, instPtr->gc);
  698.     ckfree((char *) instPtr);
  699. }
  700.  
  701. /*
  702.  *----------------------------------------------------------------------
  703.  *
  704.  * ImageDelete --
  705.  *
  706.  *    This procedure is called to clean up a test image when
  707.  *    an application goes away.
  708.  *
  709.  * Results:
  710.  *    None.
  711.  *
  712.  * Side effects:
  713.  *    Information about the image is deleted.
  714.  *
  715.  *----------------------------------------------------------------------
  716.  */
  717.  
  718. static void
  719. ImageDelete(clientData)
  720.     ClientData clientData;    /* Pointer to TImageMaster for image.  When
  721.                  * this procedure is called, no more
  722.                  * instances exist. */
  723. {
  724.     TImageMaster *timPtr = (TImageMaster *) clientData;
  725.     char buffer[100];
  726.  
  727.     sprintf(buffer, "%s delete", timPtr->imageName);
  728.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  729.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  730.  
  731.     Tcl_DeleteCommand(timPtr->interp, timPtr->imageName);
  732.     ckfree(timPtr->imageName);
  733.     ckfree(timPtr->varName);
  734.     ckfree((char *) timPtr);
  735. }
  736.  
  737. /*
  738.  *----------------------------------------------------------------------
  739.  *
  740.  * TestmakeexistCmd --
  741.  *
  742.  *    This procedure implements the "testmakeexist" command.  It calls
  743.  *    Tk_MakeWindowExist on each of its arguments to force the windows
  744.  *    to be created.
  745.  *
  746.  * Results:
  747.  *    A standard Tcl result.
  748.  *
  749.  * Side effects:
  750.  *    Forces windows to be created.
  751.  *
  752.  *----------------------------------------------------------------------
  753.  */
  754.  
  755.     /* ARGSUSED */
  756. static int
  757. TestmakeexistCmd(clientData, interp, argc, argv)
  758.     ClientData clientData;        /* Main window for application. */
  759.     Tcl_Interp *interp;            /* Current interpreter. */
  760.     int argc;                /* Number of arguments. */
  761.     char **argv;            /* Argument strings. */
  762. {
  763.     Tk_Window mainwin = (Tk_Window) clientData;
  764.     int i;
  765.     Tk_Window tkwin;
  766.  
  767.     for (i = 1; i < argc; i++) {
  768.     tkwin = Tk_NameToWindow(interp, argv[i], mainwin);
  769.     if (tkwin == NULL) {
  770.         return TCL_ERROR;
  771.     }
  772.     Tk_MakeWindowExist(tkwin);
  773.     }
  774.  
  775.     return TCL_OK;
  776. }
  777.  
  778. /*
  779.  *----------------------------------------------------------------------
  780.  *
  781.  * TestmenubarCmd --
  782.  *
  783.  *    This procedure implements the "testmenubar" command.  It is used
  784.  *    to test the Unix facilities for creating space above a toplevel
  785.  *    window for a menubar.
  786.  *
  787.  * Results:
  788.  *    A standard Tcl result.
  789.  *
  790.  * Side effects:
  791.  *    Changes menubar related stuff.
  792.  *
  793.  *----------------------------------------------------------------------
  794.  */
  795.  
  796.     /* ARGSUSED */
  797. static int
  798. TestmenubarCmd(clientData, interp, argc, argv)
  799.     ClientData clientData;        /* Main window for application. */
  800.     Tcl_Interp *interp;            /* Current interpreter. */
  801.     int argc;                /* Number of arguments. */
  802.     char **argv;            /* Argument strings. */
  803. {
  804. #ifdef __UNIX__
  805.     Tk_Window mainwin = (Tk_Window) clientData;
  806.     Tk_Window tkwin, menubar;
  807.  
  808.     if (argc < 2) {
  809.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  810.         " option ?arg ...?\"", (char *) NULL);
  811.     return TCL_ERROR;
  812.     }
  813.  
  814.     if (strcmp(argv[1], "window") == 0) {
  815.     if (argc != 4) {
  816.         Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  817.             "window toplevel menubar\"", (char *) NULL);
  818.         return TCL_ERROR;
  819.     }
  820.     tkwin = Tk_NameToWindow(interp, argv[2], mainwin);
  821.     if (tkwin == NULL) {
  822.         return TCL_ERROR;
  823.     }
  824.     if (argv[3][0] == 0) {
  825.         TkUnixSetMenubar(tkwin, NULL);
  826.     } else {
  827.         menubar = Tk_NameToWindow(interp, argv[3], mainwin);
  828.         if (menubar == NULL) {
  829.         return TCL_ERROR;
  830.         }
  831.         TkUnixSetMenubar(tkwin, menubar);
  832.     }
  833.     } else {
  834.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  835.         "\": must be  window", (char *) NULL);
  836.     return TCL_ERROR;
  837.     }
  838.  
  839.     return TCL_OK;
  840. #else
  841.     interp->result = "testmenubar is supported only under Unix";
  842.     return TCL_ERROR;
  843. #endif
  844. }
  845.  
  846. /*
  847.  *----------------------------------------------------------------------
  848.  *
  849.  * TestmetricsCmd --
  850.  *
  851.  *    This procedure implements the testmetrics command. It provides
  852.  *    a way to determine the size of various widget components.
  853.  *
  854.  * Results:
  855.  *    A standard Tcl result.
  856.  *
  857.  * Side effects:
  858.  *    None.
  859.  *
  860.  *----------------------------------------------------------------------
  861.  */
  862.  
  863. #ifdef __WIN32__
  864. static int
  865. TestmetricsCmd(clientData, interp, argc, argv)
  866.     ClientData clientData;        /* Main window for application. */
  867.     Tcl_Interp *interp;            /* Current interpreter. */
  868.     int argc;                /* Number of arguments. */
  869.     char **argv;            /* Argument strings. */
  870. {
  871.     char buf[200];
  872.  
  873.     if (argc < 2) {
  874.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  875.         " option ?arg ...?\"", (char *) NULL);
  876.     return TCL_ERROR;
  877.     }
  878.  
  879.     if (strcmp(argv[1], "cyvscroll") == 0) {
  880.     sprintf(buf, "%d", GetSystemMetrics(SM_CYVSCROLL));
  881.     Tcl_AppendResult(interp, buf, (char *) NULL);
  882.     } else  if (strcmp(argv[1], "cxhscroll") == 0) {
  883.     sprintf(buf, "%d", GetSystemMetrics(SM_CXHSCROLL));
  884.     Tcl_AppendResult(interp, buf, (char *) NULL);
  885.     } else {
  886.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  887.         "\": must be cxhscroll or cyvscroll", (char *) NULL);
  888.     return TCL_ERROR;
  889.     }
  890.     return TCL_OK;
  891. }
  892. #endif
  893. #ifdef MAC_TCL
  894. static int
  895. TestmetricsCmd(clientData, interp, argc, argv)
  896.     ClientData clientData;        /* Main window for application. */
  897.     Tcl_Interp *interp;            /* Current interpreter. */
  898.     int argc;                /* Number of arguments. */
  899.     char **argv;            /* Argument strings. */
  900. {
  901.     Tk_Window tkwin = (Tk_Window) clientData;
  902.     TkWindow *winPtr;
  903.     char buf[200];
  904.  
  905.     if (argc != 3) {
  906.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  907.         " option window\"", (char *) NULL);
  908.     return TCL_ERROR;
  909.     }
  910.  
  911.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin);
  912.     if (winPtr == NULL) {
  913.     return TCL_ERROR;
  914.     }
  915.     
  916.     if (strcmp(argv[1], "cyvscroll") == 0) {
  917.     sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
  918.     Tcl_AppendResult(interp, buf, (char *) NULL);
  919.     } else  if (strcmp(argv[1], "cxhscroll") == 0) {
  920.     sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
  921.     Tcl_AppendResult(interp, buf, (char *) NULL);
  922.     } else {
  923.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  924.         "\": must be cxhscroll or cyvscroll", (char *) NULL);
  925.     return TCL_ERROR;
  926.     }
  927.     return TCL_OK;
  928. }
  929. #endif
  930. #ifdef __OS2__
  931. static int
  932. TestmetricsCmd(clientData, interp, argc, argv)
  933.     ClientData clientData;        /* Main window for application. */
  934.     Tcl_Interp *interp;            /* Current interpreter. */
  935.     int argc;                /* Number of arguments. */
  936.     char **argv;            /* Argument strings. */
  937. {
  938.     char buf[200];
  939.  
  940.     if (argc < 2) {
  941.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  942.         " option ?arg ...?\"", (char *) NULL);
  943.     return TCL_ERROR;
  944.     }
  945.  
  946.     if (strcmp(argv[1], "cyvscroll") == 0) {
  947.     sprintf(buf, "%d", WinQuerySysValue(HWND_DESKTOP, SV_CYVSCROLLARROW));
  948.     Tcl_AppendResult(interp, buf, (char *) NULL);
  949.     } else  if (strcmp(argv[1], "cxhscroll") == 0) {
  950.     sprintf(buf, "%d", WinQuerySysValue(HWND_DESKTOP, SV_CXHSCROLLARROW));
  951.     Tcl_AppendResult(interp, buf, (char *) NULL);
  952.     } else {
  953.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  954.         "\": must be cxhscroll or cyvscroll", (char *) NULL);
  955.     return TCL_ERROR;
  956.     }
  957.     return TCL_OK;
  958. }
  959. #endif
  960.  
  961. /*
  962.  *----------------------------------------------------------------------
  963.  *
  964.  * TestpropCmd --
  965.  *
  966.  *    This procedure implements the "testprop" command.  It fetches
  967.  *    and prints the value of a property on a window.
  968.  *
  969.  * Results:
  970.  *    A standard Tcl result.
  971.  *
  972.  * Side effects:
  973.  *    None.
  974.  *
  975.  *----------------------------------------------------------------------
  976.  */
  977.  
  978.     /* ARGSUSED */
  979. static int
  980. TestpropCmd(clientData, interp, argc, argv)
  981.     ClientData clientData;        /* Main window for application. */
  982.     Tcl_Interp *interp;            /* Current interpreter. */
  983.     int argc;                /* Number of arguments. */
  984.     char **argv;            /* Argument strings. */
  985. {
  986.     Tk_Window mainwin = (Tk_Window) clientData;
  987.     int result, actualFormat;
  988.     unsigned long bytesAfter, length, value;
  989.     Atom actualType, propName;
  990.     char *property, *p, *end;
  991.     Window w;
  992.     char buffer[30];
  993.  
  994.     if (argc != 3) {
  995.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  996.         " window property\"", (char *) NULL);
  997.     return TCL_ERROR;
  998.     }
  999.  
  1000.     w = strtoul(argv[1], &end, 0);
  1001.     propName = Tk_InternAtom(mainwin, argv[2]);
  1002.     property = NULL;
  1003.     result = XGetWindowProperty(Tk_Display(mainwin),
  1004.         w, propName, 0, 100000, False, AnyPropertyType,
  1005.         &actualType, &actualFormat, &length,
  1006.         &bytesAfter, (unsigned char **) &property);
  1007.     if ((result == Success) && (actualType != None)) {
  1008.     if ((actualFormat == 8) && (actualType == XA_STRING)) {
  1009.         for (p = property; ((unsigned long)(p-property)) < length; p++) {
  1010.         if (*p == 0) {
  1011.             *p = '\n';
  1012.         }
  1013.         }
  1014.         Tcl_SetResult(interp, property, TCL_VOLATILE);
  1015.     } else {
  1016.         for (p = property; length > 0; length--) {
  1017.         if (actualFormat == 32) {
  1018.             value = *((long *) p);
  1019.             p += sizeof(long);
  1020.         } else if (actualFormat == 16) {
  1021.             value = 0xffff & (*((short *) p));
  1022.             p += sizeof(short);
  1023.         } else {
  1024.             value = 0xff & *p;
  1025.             p += 1;
  1026.         }
  1027.         sprintf(buffer, "0x%lx", value);
  1028.         Tcl_AppendElement(interp, buffer);
  1029.         }
  1030.     }
  1031.     }
  1032.     if (property != NULL) {
  1033.     XFree(property);
  1034.     }
  1035.     return TCL_OK;
  1036. }
  1037.  
  1038. /*
  1039.  *----------------------------------------------------------------------
  1040.  *
  1041.  * TestsendCmd --
  1042.  *
  1043.  *    This procedure implements the "testsend" command.  It provides
  1044.  *    a set of functions for testing the "send" command and support
  1045.  *    procedure in tkSend.c.
  1046.  *
  1047.  * Results:
  1048.  *    A standard Tcl result.
  1049.  *
  1050.  * Side effects:
  1051.  *    Depends on option;  see below.
  1052.  *
  1053.  *----------------------------------------------------------------------
  1054.  */
  1055.  
  1056.     /* ARGSUSED */
  1057. static int
  1058. TestsendCmd(clientData, interp, argc, argv)
  1059.     ClientData clientData;        /* Main window for application. */
  1060.     Tcl_Interp *interp;            /* Current interpreter. */
  1061.     int argc;                /* Number of arguments. */
  1062.     char **argv;            /* Argument strings. */
  1063. {
  1064.     TkWindow *winPtr = (TkWindow *) clientData;
  1065.  
  1066.     if (argc < 2) {
  1067.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1068.         " option ?arg ...?\"", (char *) NULL);
  1069.     return TCL_ERROR;
  1070.     }
  1071.  
  1072. #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__))
  1073.     if (strcmp(argv[1], "bogus") == 0) {
  1074.     XChangeProperty(winPtr->dispPtr->display,
  1075.         RootWindow(winPtr->dispPtr->display, 0),
  1076.         winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
  1077.         PropModeReplace,
  1078.         (unsigned char *) "This is bogus information", 6);
  1079.     } else if (strcmp(argv[1], "prop") == 0) {
  1080.     int result, actualFormat;
  1081.     unsigned long length, bytesAfter;
  1082.     Atom actualType, propName;
  1083.     char *property, *p, *end;
  1084.     Window w;
  1085.  
  1086.     if ((argc != 4) && (argc != 5)) {
  1087.         Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1088.             " prop window name ?value ?\"", (char *) NULL);
  1089.         return TCL_ERROR;
  1090.     }
  1091.     if (strcmp(argv[2], "root") == 0) {
  1092.         w = RootWindow(winPtr->dispPtr->display, 0);
  1093.     } else if (strcmp(argv[2], "comm") == 0) {
  1094.         w = Tk_WindowId(winPtr->dispPtr->commTkwin);
  1095.     } else {
  1096.         w = strtoul(argv[2], &end, 0);
  1097.     }
  1098.     propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]);
  1099.     if (argc == 4) {
  1100.         property = NULL;
  1101.         result = XGetWindowProperty(winPtr->dispPtr->display,
  1102.             w, propName, 0, 100000, False, XA_STRING,
  1103.             &actualType, &actualFormat, &length,
  1104.             &bytesAfter, (unsigned char **) &property);
  1105.         if ((result == Success) && (actualType != None)
  1106.             && (actualFormat == 8) && (actualType == XA_STRING)) {
  1107.         for (p = property; (p-property) < length; p++) {
  1108.             if (*p == 0) {
  1109.             *p = '\n';
  1110.             }
  1111.         }
  1112.         Tcl_SetResult(interp, property, TCL_VOLATILE);
  1113.         }
  1114.         if (property != NULL) {
  1115.         XFree(property);
  1116.         }
  1117.     } else {
  1118.         if (argv[4][0] == 0) {
  1119.         XDeleteProperty(winPtr->dispPtr->display, w, propName);
  1120.         } else {
  1121.         for (p = argv[4]; *p != 0; p++) {
  1122.             if (*p == '\n') {
  1123.             *p = 0;
  1124.             }
  1125.         }
  1126.         XChangeProperty(winPtr->dispPtr->display,
  1127.             w, propName, XA_STRING, 8, PropModeReplace,
  1128.             (unsigned char *) argv[4], p-argv[4]);
  1129.         }
  1130.     }
  1131.     } else if (strcmp(argv[1], "serial") == 0) {
  1132.     sprintf(interp->result, "%d", tkSendSerial+1);
  1133.     } else {
  1134.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1135.         "\": must be bogus, prop, or serial", (char *) NULL);
  1136.     return TCL_ERROR;
  1137.     }
  1138. #endif
  1139.     return TCL_OK;
  1140. }
  1141.  
  1142. #if !(defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__))
  1143. /*
  1144.  *----------------------------------------------------------------------
  1145.  *
  1146.  * TestwrapperCmd --
  1147.  *
  1148.  *    This procedure implements the "testwrapper" command.  It 
  1149.  *    provides a way from Tcl to determine the extra window Tk adds
  1150.  *    in between the toplevel window and the window decorations.
  1151.  *
  1152.  * Results:
  1153.  *    A standard Tcl result.
  1154.  *
  1155.  * Side effects:
  1156.  *    None.
  1157.  *
  1158.  *----------------------------------------------------------------------
  1159.  */
  1160.  
  1161.     /* ARGSUSED */
  1162. static int
  1163. TestwrapperCmd(clientData, interp, argc, argv)
  1164.     ClientData clientData;        /* Main window for application. */
  1165.     Tcl_Interp *interp;            /* Current interpreter. */
  1166.     int argc;                /* Number of arguments. */
  1167.     char **argv;            /* Argument strings. */
  1168. {
  1169.     TkWindow *winPtr, *wrapperPtr;
  1170.     Tk_Window tkwin;
  1171.  
  1172.     if (argc != 2) {
  1173.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1174.         " window\"", (char *) NULL);
  1175.     return TCL_ERROR;
  1176.     }
  1177.     
  1178.     tkwin = (Tk_Window) clientData;
  1179.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
  1180.     if (winPtr == NULL) {
  1181.     return TCL_ERROR;
  1182.     }
  1183.  
  1184.     wrapperPtr = TkpGetWrapperWindow(winPtr);
  1185.     if (wrapperPtr != NULL) {
  1186.     TkpPrintWindowId(interp->result, Tk_WindowId(wrapperPtr));
  1187.     }
  1188.     return TCL_OK;
  1189. }
  1190. #endif
  1191.