1/*
2 * tclXtest.c --
3 *
4 *  Test support functions for the Extended Tcl test program.
5 *
6 *-----------------------------------------------------------------------------
7 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
8 *
9 * Permission to use, copy, modify, and distribute this software and its
10 * documentation for any purpose and without fee is hereby granted, provided
11 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
12 * Mark Diekhans make no representations about the suitability of this
13 * software for any purpose.  It is provided "as is" without express or
14 * implied warranty.
15 *-----------------------------------------------------------------------------
16 * $Id: tclXtest.c,v 1.2 2002/04/03 02:50:35 hobbs Exp $
17 *-----------------------------------------------------------------------------
18 */
19
20#include "tclExtdInt.h"
21
22int
23Tclxtest_Init _ANSI_ARGS_((Tcl_Interp *interp));
24
25int
26TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
27
28int
29Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
30
31/*
32 * Error handler proc that causes errors to come out in the same format as
33 * the standard Tcl test shell.  This keeps certain Tcl tests from reporting
34 * errors.
35 */
36static char errorHandler [] =
37    "proc tclx_errorHandler msg {global errorInfo; \
38     if [lempty $errorInfo] {puts $msg} else {puts stderr $errorInfo}; \
39     exit 1}";
40
41/*
42 * Prototypes of internal functions.
43 */
44static int
45DoTestEval _ANSI_ARGS_((Tcl_Interp  *interp,
46                        char        *levelStr,
47                        char        *command,
48                        Tcl_Obj     *resultList));
49
50static int
51TclxTestEvalCmd _ANSI_ARGS_((ClientData    clientData,
52                             Tcl_Interp   *interp,
53                             int           argc,
54                             char        **argv));
55
56
57/*-----------------------------------------------------------------------------
58 * DoTestEval --
59 *   Evaluate a level/command pair.
60 * Parameters:
61 *   o interp - Errors are returned in result.
62 *   o levelStr - Level string to parse.
63 *   o command - Command to evaluate.
64 *   o resultList - List object to append the two element eval code and result
65 *     to.
66 * Returns:
67 *   TCL_OK or TCL_ERROR.
68 *-----------------------------------------------------------------------------
69 */
70static int
71DoTestEval (interp, levelStr, command, resultList)
72    Tcl_Interp  *interp;
73    char        *levelStr;
74    char        *command;
75    Tcl_Obj     *resultList;
76{
77    Interp *iPtr = (Interp *) interp;
78    int code;
79    Tcl_Obj *subResult;
80    CallFrame *savedVarFramePtr, *framePtr;
81
82    /*
83     * Find the frame to eval in.
84     */
85    code = TclGetFrame (interp, levelStr, &framePtr);
86    if (code <= 0) {
87        if (code == 0)
88            TclX_AppendObjResult (interp, "invalid level \"", levelStr, "\"",
89                                  (char *) NULL);
90        return TCL_ERROR;
91    }
92
93    /*
94     * Evaluate in the new environment.
95     */
96    savedVarFramePtr = iPtr->varFramePtr;
97    iPtr->varFramePtr = framePtr;
98
99    code = Tcl_Eval (interp, command);
100
101    iPtr->varFramePtr = savedVarFramePtr;
102
103    /*
104     * Append the two element list.
105     */
106    subResult = Tcl_NewListObj (0, NULL);
107    if (Tcl_ListObjAppendElement (interp, subResult,
108                                  Tcl_NewIntObj (code)) != TCL_OK)
109        return TCL_ERROR;
110    if (Tcl_ListObjAppendElement (interp, subResult,
111                                  Tcl_GetObjResult (interp)) != TCL_OK)
112        return TCL_ERROR;
113    if (Tcl_ListObjAppendElement (interp, resultList, subResult) != TCL_OK)
114        return TCL_ERROR;
115
116    return TCL_OK;
117}
118
119
120/*-----------------------------------------------------------------------------
121 * TclxTestEvalCmd --
122 *    Command used in profile test.  It purpose is to evaluate a series of
123 * commands at a specified level.  Its like uplevel, but can generate more
124 * complex situations.  Level is specified in the same manner as uplevel,
125 * with 0 being the current level.
126 *     tclx_test_eval ?level cmd? ?level cmd? ...
127 *
128 * Results:
129 *   A list contain a list entry for each command evaluated.  Each entry is
130 * the eval code and result string.
131 *-----------------------------------------------------------------------------
132 */
133static int
134TclxTestEvalCmd (clientData, interp, argc, argv)
135    ClientData    clientData;
136    Tcl_Interp   *interp;
137    int           argc;
138    char        **argv;
139{
140    int idx;
141    Tcl_Obj *resultList;
142
143    if (((argc - 1) % 2) != 0) {
144        TclX_AppendObjResult (interp, "wrong # args: ", argv [0],
145                              " ?level cmd? ?level cmd? ...", (char *) NULL);
146        return TCL_ERROR;
147    }
148
149    resultList = Tcl_NewListObj (0, NULL);
150
151    for (idx = 1; idx < argc; idx += 2) {
152        if (DoTestEval (interp, argv [idx], argv [idx + 1],
153                        resultList) == TCL_ERROR) {
154            Tcl_DecrRefCount (resultList);
155            return TCL_ERROR;
156        }
157    }
158
159    Tcl_SetObjResult (interp, resultList);
160    return TCL_OK;
161}
162
163/*-----------------------------------------------------------------------------
164 * Tclxtest_Init --
165 *  Initialize TclX test support.
166 *
167 * Results:
168 *   Returns a standard Tcl completion code, and leaves an error message in
169 * interp result if an error occurs.
170 *-----------------------------------------------------------------------------
171 */
172int
173Tclxtest_Init (interp)
174    Tcl_Interp *interp;
175{
176    Tcl_CreateCommand (interp, "tclx_test_eval", TclxTestEvalCmd,
177                       (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL);
178
179    /*
180     * Add in standard Tcl tests support.
181     */
182    if (Tcltest_Init(interp) == TCL_ERROR) {
183	return TCL_ERROR;
184    }
185    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
186            (Tcl_PackageInitProc *) NULL);
187    if (TclObjTest_Init(interp) == TCL_ERROR) {
188	return TCL_ERROR;
189    }
190    return Tcl_GlobalEval (interp, errorHandler);
191}
192
193
194