diff options
Diffstat (limited to 'vendor/x11iraf/obm/Tcl/tclTest.c')
| -rw-r--r-- | vendor/x11iraf/obm/Tcl/tclTest.c | 786 |
1 files changed, 786 insertions, 0 deletions
diff --git a/vendor/x11iraf/obm/Tcl/tclTest.c b/vendor/x11iraf/obm/Tcl/tclTest.c new file mode 100644 index 00000000..c3b19f35 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclTest.c @@ -0,0 +1,786 @@ +/* + * 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/tcl/RCS/tclTest.c,v 1.15 93/09/09 16:46:52 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.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; + +/* + * Dynamic string shared by TestdcallCmd and DelCallbackProc; used + * to collect the results of the various deletion callbacks. + */ + +static Tcl_DString delString; +static Tcl_Interp *delInterp; + +/* + * One of the following structures exists for each asynchronous + * handler created by the "testasync" command". + */ + +typedef struct TestAsyncHandler { + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the + * handler is invoked. */ + struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ +} TestAsyncHandler; + +static TestAsyncHandler *firstHandler = NULL; + +/* + * The variable below is a token for an asynchronous handler for + * interrupt signals, or NULL if none exists. + */ + +static Tcl_AsyncHandler intHandler; + +/* + * The dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); +static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); +static int CmdProc1 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int CmdProc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static int IntHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void IntProc(); +static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestMathFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + /* + * 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; + } + + /* + * Create additional commands and math functions for testing Tcl. + */ + + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 345); + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. If this line is deleted then no user-specific + * startup file will be run under any conditions. + */ + + tcl_RcFileName = "~/.tclshrc"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestasyncCmd -- + * + * This procedure implements the "testasync" command. It is used + * to test the asynchronous handler facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestasyncCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TestAsyncHandler *asyncPtr, *prevPtr; + int id, code; + static int nextId = 1; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->id = nextId; + nextId++; + asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, + (ClientData) asyncPtr); + asyncPtr->command = ckalloc((unsigned) (strlen(argv[2]) + 1)); + strcpy(asyncPtr->command, argv[2]); + asyncPtr->nextPtr = firstHandler; + firstHandler = asyncPtr; + sprintf(interp->result, "%d", asyncPtr->id); + } else if (strcmp(argv[1], "delete") == 0) { + if (argc == 2) { + while (firstHandler != NULL) { + asyncPtr = firstHandler; + firstHandler = asyncPtr->nextPtr; + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + } + return TCL_OK; + } + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; + prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id != id) { + continue; + } + if (prevPtr == NULL) { + firstHandler = asyncPtr->nextPtr; + } else { + prevPtr->nextPtr = asyncPtr->nextPtr; + } + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + break; + } + } else if (strcmp(argv[1], "int") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + intHandler = Tcl_AsyncCreate(IntHandlerProc, (ClientData) interp); + signal(SIGINT, IntProc); + } else if (strcmp(argv[1], "mark") == 0) { + if (argc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +AsyncHandlerProc(clientData, interp, code) + ClientData clientData; /* Pointer to TestAsyncHandler structure. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + char *listArgv[4]; + char string[20], *cmd; + + sprintf(string, "%d", code); + listArgv[0] = asyncPtr->command; + listArgv[1] = interp->result; + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +static void +IntProc() +{ + Tcl_AsyncMark(intHandler); +} + +static int +IntHandlerProc(clientData, interp, code) + ClientData clientData; /* Interpreter in which to invoke command. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + char *listArgv[4]; + char string[20], *cmd; + + interp = (Tcl_Interp *) clientData; + listArgv[0] = Tcl_GetVar(interp, "sigIntCmd", TCL_GLOBAL_ONLY); + if (listArgv[0] == NULL) { + return code; + } + listArgv[1] = interp->result; + sprintf(string, "%d", code); + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestdcallCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdcallCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, id; + + delInterp = Tcl_CreateInterp(); + Tcl_DStringInit(&delString); + for (i = 1; i < argc; i++) { + if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { + return TCL_ERROR; + } + if (id < 0) { + Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) (-id)); + } else { + Tcl_CallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) id); + } + } + Tcl_DeleteInterp(delInterp); + Tcl_DStringResult(interp, &delString); + return TCL_OK; +} + +/* + * The deletion callback used by TestdcallCmd: + */ + +static void +DelCallbackProc(clientData, interp) + ClientData clientData; /* Numerical value to append to + * delString. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + int id = (int) clientData; + char buffer[10]; + + sprintf(buffer, "%d", id); + Tcl_DStringAppendElement(&delString, buffer); + if (interp != delInterp) { + Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCmdInfo, Tcl_SetCmdInfo, and command creation + * and deletion. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdinfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DStringInit(&delString); + Tcl_DeleteCommand(interp, argv[2]); + Tcl_DStringResult(interp, &delString); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + interp->result = "??"; + return TCL_OK; + } + if (info.proc == CmdProc1) { + Tcl_AppendResult(interp, "CmdProc1", " ", + (char *) info.clientData, (char *) NULL); + } else if (info.proc == CmdProc2) { + Tcl_AppendResult(interp, "CmdProc2", " ", + (char *) info.clientData, (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown", (char *) NULL); + } + if (info.deleteProc == CmdDelProc1) { + Tcl_AppendResult(interp, " CmdDelProc1", " ", + (char *) info.deleteData, (char *) NULL); + } else if (info.deleteProc == CmdDelProc2) { + Tcl_AppendResult(interp, " CmdDelProc2", " ", + (char *) info.deleteData, (char *) NULL); + } else { + Tcl_AppendResult(interp, " unknown", (char *) NULL); + } + } else if (strcmp(argv[1], "modify") == 0) { + info.proc = CmdProc2; + info.clientData = (ClientData) "new_command_data"; + info.deleteProc = CmdDelProc2; + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + interp->result = "0"; + } else { + interp->result = "1"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc1(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + +static void +CmdDelProc1(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +static void +CmdDelProc2(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TestdstringCmd -- + * + * This procedure implements the "testdstring" command. It is used + * to test the dynamic string facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdstringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "append") == 0) { + if (argc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringAppend(&dstring, argv[2], count); + } else if (strcmp(argv[1], "element") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + Tcl_DStringAppendElement(&dstring, argv[2]); + } else if (strcmp(argv[1], "end") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringEndSublist(&dstring); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringFree(&dstring); + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + interp->result = Tcl_DStringValue(&dstring); + } else if (strcmp(argv[1], "length") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + sprintf(interp->result, "%d", Tcl_DStringLength(&dstring)); + } else if (strcmp(argv[1], "result") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "trunc") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringTrunc(&dstring, count); + } else if (strcmp(argv[1], "start") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringStartSublist(&dstring); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be append, element, end, free, get, length, ", + "result, trunc, or start", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestlinkCmd -- + * + * This procedure implements the "testlink" command. It is used + * to test Tcl_LinkVar and related library procedures. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various variable links, plus returns + * values of the linked variables. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestlinkCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int intVar = 43; + static int boolVar = 4; + static double realVar = 1.23; + static char *stringVar = NULL; + char buffer[TCL_DOUBLE_SPACE]; + int writable, flag; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg arg?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, + TCL_LINK_INT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, + TCL_LINK_DOUBLE | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, + TCL_LINK_BOOLEAN | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, + TCL_LINK_STRING | flag) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } else if (strcmp(argv[1], "get") == 0) { + sprintf(buffer, "%d", intVar); + Tcl_AppendElement(interp, buffer); + Tcl_PrintDouble(interp, realVar, buffer); + Tcl_AppendElement(interp, buffer); + sprintf(buffer, "%d", boolVar); + Tcl_AppendElement(interp, buffer); + Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + } else if (strcmp(argv[1], "set") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, or set", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc -- + * + * This is a user-defined math procedure to test out math procedures + * with no arguments. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Not used. */ + Tcl_Value *args; /* Not used. */ + Tcl_Value *resultPtr; /* Where to store result. */ +{ + resultPtr->type = TCL_INT; + resultPtr->intValue = (int) clientData; + return TCL_OK; +} |