160 lines
4.6 KiB
C
160 lines
4.6 KiB
C
/*
|
||
* tclTest.c --
|
||
*
|
||
* This file contains C command procedures for a bunch of additional
|
||
* Tcl commands that are used for testing out Tcl's C interfaces.
|
||
* These commands are not normally included in Tcl applications;
|
||
* they're only used for testing.
|
||
*
|
||
* Copyright (c) 1993 The Regents of the University of California.
|
||
* All rights reserved.
|
||
*
|
||
* Permission is hereby granted, without written agreement and without
|
||
* license or royalty fees, to use, copy, modify, and distribute this
|
||
* software and its documentation for any purpose, provided that the
|
||
* above copyright notice and the following two paragraphs appear in
|
||
* all copies of this software.
|
||
*
|
||
* IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||
* CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||
*
|
||
* THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||
* AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||
* ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||
*/
|
||
|
||
#ifndef lint
|
||
static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTest.c,v 1.6 93/08/26 14:38:22 ouster Exp $ SPRITE (Berkeley)";
|
||
#endif /* not lint */
|
||
|
||
#include "tk.h"
|
||
#include "tkConfig.h"
|
||
|
||
/*
|
||
* The following variable is a special hack that allows applications
|
||
* to be linked using the procedure "main" from the Tcl library. The
|
||
* variable generates a reference to "main", which causes main to
|
||
* be brought in from the library (and all of Tcl with it).
|
||
*/
|
||
|
||
extern int main();
|
||
int *tclDummyMainPtr = (int *) main;
|
||
|
||
/*
|
||
* Forward declarations for procedures defined later in this file:
|
||
*/
|
||
|
||
static int TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
|
||
Tcl_Interp *interp, int argc, char **argv));
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_AppInit --
|
||
*
|
||
* This procedure performs application-specific initialization.
|
||
* Most applications, especially those that incorporate additional
|
||
* packages, will have their own version of this procedure.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl completion code, and leaves an error
|
||
* message in interp->result if an error occurs.
|
||
*
|
||
* Side effects:
|
||
* Depends on the startup script.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_AppInit(interp)
|
||
Tcl_Interp *interp; /* Interpreter for application. */
|
||
{
|
||
Tk_Window main;
|
||
|
||
main = Tk_MainWindow(interp);
|
||
if (main == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Call the init procedures for included packages. Each call should
|
||
* look like this:
|
||
*
|
||
* if (Mod_Init(interp) == TCL_ERROR) {
|
||
* return TCL_ERROR;
|
||
* }
|
||
*
|
||
* where "Mod" is the name of the module.
|
||
*/
|
||
|
||
if (Tcl_Init(interp) == TCL_ERROR) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tk_Init(interp) == TCL_ERROR) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Create additional commands for testing Tk.
|
||
*/
|
||
|
||
Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
|
||
(ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
|
||
|
||
/*
|
||
* Specify a user-specific startup file to invoke if the application
|
||
* is run interactively. Typically the startup file is "~/.apprc"
|
||
* where "app" is the name of the application. If this line is deleted
|
||
* then no user-specific startup file will be run under any conditions.
|
||
*/
|
||
|
||
tcl_RcFileName = "~/.wishrc";
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TestmakeexistCmd --
|
||
*
|
||
* This procedure implements the "testmakeexist" command. It calls
|
||
* Tk_MakeWindowExist on each of its arguments to force the windows
|
||
* to be created.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* Creates and deletes interpreters.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static int
|
||
TestmakeexistCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window for application. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window main = (Tk_Window) clientData;
|
||
int i;
|
||
Tk_Window tkwin;
|
||
|
||
for (i = 1; i < argc; i++) {
|
||
tkwin = Tk_NameToWindow(interp, argv[i], main);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tk_MakeWindowExist(tkwin);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|