home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tk3.3b1 / tkTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-08  |  4.6 KB  |  155 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 The Regents of the University of California.
  10.  * All rights reserved.
  11.  *
  12.  * Permission is hereby granted, without written agreement and without
  13.  * license or royalty fees, to use, copy, modify, and distribute this
  14.  * software and its documentation for any purpose, provided that the
  15.  * above copyright notice and the following two paragraphs appear in
  16.  * all copies of this software.
  17.  * 
  18.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22.  *
  23.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28.  */
  29.  
  30. #ifndef lint
  31. static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTest.c,v 1.3 93/07/08 14:26:29 ouster Exp $ SPRITE (Berkeley)";
  32. #endif /* not lint */
  33.  
  34. #include "tk.h"
  35. #include "tkConfig.h"    
  36.  
  37. /*
  38.  * The variable below holds a startup script to be executed at the
  39.  * beginning of the application.
  40.  */
  41.  
  42. char initCmd[] =
  43. "if [file exists $tk_library/wish.tcl] {\n\
  44.     source $tk_library/wish.tcl\n\
  45. } else {\n\
  46.     set msg \"can't find $tk_library/wish.tcl; perhaps you need to\\n\"\n\
  47.     append msg \"install Tk or set your TK_LIBRARY environment \"\n\
  48.     append msg \"variable?\"\n\
  49.     error $msg\n\
  50. }";
  51.  
  52. /*
  53.  * The following variable is a special hack that allows applications
  54.  * to be linked using the procedure "main" from the Tcl library.  The
  55.  * variable generates a reference to "main", which causes main to
  56.  * be brought in from the library (and all of Tcl with it).
  57.  */
  58.  
  59. extern int main();
  60. int *tclDummyMainPtr = (int *) main;
  61.  
  62. /*
  63.  * Forward declarations for procedures defined later in this file:
  64.  */
  65.  
  66. static int        TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
  67.                 Tcl_Interp *interp, int argc, char **argv));
  68.  
  69. /*
  70.  *----------------------------------------------------------------------
  71.  *
  72.  * Tcl_AppInit --
  73.  *
  74.  *    This procedure performs application-specific initialization.
  75.  *    Most applications, especially those that incorporate additional
  76.  *    packages, will have their own version of this procedure.
  77.  *
  78.  * Results:
  79.  *    Returns a standard Tcl completion code, and leaves an error
  80.  *    message in interp->result if an error occurs.
  81.  *
  82.  * Side effects:
  83.  *    Depends on the startup script.
  84.  *
  85.  *----------------------------------------------------------------------
  86.  */
  87.  
  88. int
  89. Tcl_AppInit(interp)
  90.     Tcl_Interp *interp;        /* Interpreter for application. */
  91. {
  92.     Tcl_CmdInfo info;
  93.  
  94.     /*
  95.      * Create additional commands for testing Tk.  Extract the
  96.      * clientData from the "button" command:  it's the main window
  97.      * for the application:
  98.      */
  99.  
  100.     if (!Tcl_GetCommandInfo(interp, "button", &info)) {
  101.     Tcl_AppendResult(interp, "Tcl_AppInit can't find the main window",
  102.         (char *) NULL);
  103.     return TCL_ERROR;
  104.     }
  105.     Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
  106.         info.clientData, (Tcl_CmdDeleteProc *) NULL);
  107.  
  108.     /*
  109.      * Execute a start-up script.
  110.      */
  111.  
  112.     return Tcl_Eval(interp, initCmd);
  113. }
  114.  
  115. /*
  116.  *----------------------------------------------------------------------
  117.  *
  118.  * TestmakeexistCmd --
  119.  *
  120.  *    This procedure implements the "testmakeexist" command.  It calls
  121.  *    Tk_MakeWindowExist on each of its arguments to force the windows
  122.  *    to be created.
  123.  *
  124.  * Results:
  125.  *    A standard Tcl result.
  126.  *
  127.  * Side effects:
  128.  *    Creates and deletes interpreters.
  129.  *
  130.  *----------------------------------------------------------------------
  131.  */
  132.  
  133.     /* ARGSUSED */
  134. static int
  135. TestmakeexistCmd(clientData, interp, argc, argv)
  136.     ClientData clientData;        /* Main window for application. */
  137.     Tcl_Interp *interp;            /* Current interpreter. */
  138.     int argc;                /* Number of arguments. */
  139.     char **argv;            /* Argument strings. */
  140. {
  141.     Tk_Window main = (Tk_Window) clientData;
  142.     int i;
  143.     Tk_Window tkwin;
  144.  
  145.     for (i = 1; i < argc; i++) {
  146.     tkwin = Tk_NameToWindow(interp, argv[i], main);
  147.     if (tkwin == NULL) {
  148.         return TCL_ERROR;
  149.     }
  150.     Tk_MakeWindowExist(tkwin);
  151.     }
  152.  
  153.     return TCL_OK;
  154. }
  155.