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