sl@0: /* sl@0: * tclTest.c -- sl@0: * sl@0: * This file contains C command procedures for a bunch of additional sl@0: * Tcl commands that are used for testing out Tcl's C interfaces. sl@0: * These commands are not normally included in Tcl applications; sl@0: * they're only used for testing. sl@0: * sl@0: * Copyright (c) 1993-1994 The Regents of the University of California. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-2000 Ajuba Solutions. sl@0: * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. sl@0: * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclTest.c,v 1.62.2.13 2006/09/22 01:26:23 andreas_kupries Exp $ sl@0: */ sl@0: #ifndef __SYMBIAN32__ sl@0: #define TCL_TEST sl@0: #endif sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #if defined(__SYMBIAN32__) sl@0: #include "tclSymbianGlobals.h" sl@0: #endif sl@0: sl@0: /* sl@0: * Required for Testregexp*Cmd sl@0: */ sl@0: #include "tclRegexp.h" sl@0: sl@0: /* sl@0: * Required for TestlocaleCmd sl@0: */ sl@0: #include sl@0: sl@0: /* sl@0: * Required for the TestChannelCmd and TestChannelEventCmd sl@0: */ sl@0: #include "tclIO.h" sl@0: sl@0: /* sl@0: * Declare external functions used in Windows tests. sl@0: */ sl@0: sl@0: /* sl@0: * Dynamic string shared by TestdcallCmd and DelCallbackProc; used sl@0: * to collect the results of the various deletion callbacks. sl@0: */ sl@0: sl@0: static Tcl_DString delString; sl@0: static Tcl_Interp *delInterp; sl@0: sl@0: /* sl@0: * One of the following structures exists for each asynchronous sl@0: * handler created by the "testasync" command". sl@0: */ sl@0: sl@0: typedef struct TestAsyncHandler { sl@0: int id; /* Identifier for this handler. */ sl@0: Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ sl@0: char *command; /* Command to invoke when the sl@0: * handler is invoked. */ sl@0: struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ sl@0: } TestAsyncHandler; sl@0: sl@0: static TestAsyncHandler *firstHandler = NULL; sl@0: sl@0: /* sl@0: * The dynamic string below is used by the "testdstring" command sl@0: * to test the dynamic string facilities. sl@0: */ sl@0: sl@0: static Tcl_DString dstring; sl@0: sl@0: /* sl@0: * The command trace below is used by the "testcmdtraceCmd" command sl@0: * to test the command tracing facilities. sl@0: */ sl@0: sl@0: static Tcl_Trace cmdTrace; sl@0: sl@0: /* sl@0: * One of the following structures exists for each command created sl@0: * by TestdelCmd: sl@0: */ sl@0: sl@0: typedef struct DelCmd { sl@0: Tcl_Interp *interp; /* Interpreter in which command exists. */ sl@0: char *deleteCmd; /* Script to execute when command is sl@0: * deleted. Malloc'ed. */ sl@0: } DelCmd; sl@0: sl@0: /* sl@0: * The following is used to keep track of an encoding that invokes a Tcl sl@0: * command. sl@0: */ sl@0: sl@0: typedef struct TclEncoding { sl@0: Tcl_Interp *interp; sl@0: char *toUtfCmd; sl@0: char *fromUtfCmd; sl@0: } TclEncoding; sl@0: sl@0: /* sl@0: * The counter below is used to determine if the TestsaveresultFree sl@0: * routine was called for a result. sl@0: */ sl@0: sl@0: static int freeCount; sl@0: sl@0: /* sl@0: * Boolean flag used by the "testsetmainloop" and "testexitmainloop" sl@0: * commands. sl@0: */ sl@0: static int exitMainLoop = 0; sl@0: sl@0: /* sl@0: * Event structure used in testing the event queue management procedures. sl@0: */ sl@0: typedef struct TestEvent { sl@0: Tcl_Event header; /* Header common to all events */ sl@0: Tcl_Interp* interp; /* Interpreter that will handle the event */ sl@0: Tcl_Obj* command; /* Command to evaluate when the event occurs */ sl@0: Tcl_Obj* tag; /* Tag for this event used to delete it */ sl@0: } TestEvent; sl@0: sl@0: /* sl@0: * Forward declarations for procedures defined later in this file: sl@0: */ sl@0: sl@0: int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); sl@0: static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int code)); sl@0: static void CleanupTestSetassocdataTests _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp)); sl@0: static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); sl@0: static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); sl@0: static int CmdProc1 _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int CmdProc2 _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static void CmdTraceDeleteProc _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int level, char *command, Tcl_CmdProc *cmdProc, sl@0: ClientData cmdClientData, int argc, sl@0: char **argv)); sl@0: static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int level, char *command, sl@0: Tcl_CmdProc *cmdProc, ClientData cmdClientData, sl@0: int argc, char **argv)); sl@0: static int CreatedCommandProc _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int argc, CONST char **argv)); sl@0: static int CreatedCommandProc2 _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int argc, CONST char **argv)); sl@0: static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp)); sl@0: static int DelCmdProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); sl@0: static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData)); sl@0: static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData, sl@0: CONST char *src, int srcLen, int flags, sl@0: Tcl_EncodingState *statePtr, char *dst, sl@0: int dstLen, int *srcReadPtr, int *dstWrotePtr, sl@0: int *dstCharsPtr)); sl@0: static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData, sl@0: CONST char *src, int srcLen, int flags, sl@0: Tcl_EncodingState *statePtr, char *dst, sl@0: int dstLen, int *srcReadPtr, int *dstWrotePtr, sl@0: int *dstCharsPtr)); sl@0: static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); sl@0: static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); sl@0: static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static void MainLoop _ANSI_ARGS_((void)); sl@0: static int NoopCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData, sl@0: Tcl_Interp* interp, sl@0: int level, sl@0: CONST char* command, sl@0: Tcl_Command commandToken, sl@0: int objc, sl@0: Tcl_Obj *CONST objv[] )); sl@0: static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData )); sl@0: static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Parse *parsePtr)); sl@0: static void SpecialFree _ANSI_ARGS_((char *blockPtr)); sl@0: static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); sl@0: static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int PretendTclpAccess _ANSI_ARGS_((CONST char *path, sl@0: int mode)); sl@0: static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, sl@0: int mode)); sl@0: static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, sl@0: int mode)); sl@0: static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, sl@0: int mode)); sl@0: static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestdelCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TesteventObjCmd _ANSI_ARGS_((ClientData unused, sl@0: Tcl_Interp* interp, sl@0: int argc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TesteventProc _ANSI_ARGS_((Tcl_Event* event, sl@0: int flags)); sl@0: static int TesteventDeleteProc _ANSI_ARGS_(( sl@0: Tcl_Event* event, sl@0: ClientData clientData)); sl@0: static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestfileCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestgetvarfullnameCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestMathFunc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, Tcl_Value *args, sl@0: Tcl_Value *resultPtr)); sl@0: static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, Tcl_Value *args, sl@0: Tcl_Value *resultPtr)); sl@0: static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, CONST char *fileName, sl@0: CONST char *modeString, int permissions)); sl@0: static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, CONST char *fileName, sl@0: CONST char *modeString, int permissions)); sl@0: static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, CONST char *fileName, sl@0: CONST char *modeString, int permissions)); sl@0: static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, CONST char *fileName, sl@0: CONST char *modeString, int permissions)); sl@0: static int TestpanicCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void TestregexpXflags _ANSI_ARGS_((char *string, sl@0: int length, int *cflagsPtr, int *eflagsPtr)); sl@0: static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); sl@0: static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestsetCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestopenfilechannelprocCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, int argc, sl@0: CONST char **argv)); sl@0: static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int PretendTclpStat _ANSI_ARGS_((CONST char *path, sl@0: struct stat *buf)); sl@0: static int TestStatProc1 _ANSI_ARGS_((CONST char *path, sl@0: struct stat *buf)); sl@0: static int TestStatProc2 _ANSI_ARGS_((CONST char *path, sl@0: struct stat *buf)); sl@0: static int TestStatProc3 _ANSI_ARGS_((CONST char *path, sl@0: struct stat *buf)); sl@0: static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestWrongNumArgsObjCmd _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: /* Filesystem testing */ sl@0: sl@0: static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int TestSimpleFilesystemObjCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: sl@0: static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1, sl@0: Tcl_Obj* arg2)); sl@0: sl@0: static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ (( sl@0: Tcl_Obj* pathObjPtr)); sl@0: sl@0: static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: Tcl_StatBuf *buf)); sl@0: static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: int mode)); sl@0: static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ (( sl@0: Tcl_Interp *interp, Tcl_Obj *fileName, sl@0: int mode, int permissions)); sl@0: static int TestReportMatchInDirectory _ANSI_ARGS_ (( sl@0: Tcl_Interp *interp, Tcl_Obj *resultPtr, sl@0: Tcl_Obj *dirPtr, CONST char *pattern, sl@0: Tcl_GlobTypeData *types)); sl@0: static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName)); sl@0: static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: Tcl_StatBuf *buf)); sl@0: static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src, sl@0: Tcl_Obj *dst)); sl@0: static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path)); sl@0: static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src, sl@0: Tcl_Obj *dst)); sl@0: static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path)); sl@0: static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src, sl@0: Tcl_Obj *dst, Tcl_Obj **errorPtr)); sl@0: static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: int recursive, Tcl_Obj **errorPtr)); sl@0: static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp, sl@0: Tcl_Obj *fileName, sl@0: Tcl_LoadHandle *handlePtr, sl@0: Tcl_FSUnloadFileProc **unloadProcPtr)); sl@0: static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: Tcl_Obj *to, int linkType)); sl@0: static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ (( sl@0: Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); sl@0: static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp, sl@0: int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); sl@0: static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp, sl@0: int index, Tcl_Obj *fileName, Tcl_Obj *objPtr)); sl@0: static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName, sl@0: struct utimbuf *tval)); sl@0: static int TestReportNormalizePath _ANSI_ARGS_ (( sl@0: Tcl_Interp *interp, Tcl_Obj *pathPtr, sl@0: int nextCheckpoint)); sl@0: static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr)); sl@0: static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData)); sl@0: static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData)); sl@0: sl@0: static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: Tcl_StatBuf *buf)); sl@0: static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path, sl@0: int mode)); sl@0: static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ (( sl@0: Tcl_Interp *interp, Tcl_Obj *fileName, sl@0: int mode, int permissions)); sl@0: static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void)); sl@0: static int SimplePathInFilesystem _ANSI_ARGS_ (( sl@0: Tcl_Obj *pathPtr, ClientData *clientDataPtr)); sl@0: static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr)); sl@0: static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: sl@0: static Tcl_Filesystem testReportingFilesystem = { sl@0: "reporting", sl@0: sizeof(Tcl_Filesystem), sl@0: TCL_FILESYSTEM_VERSION_1, sl@0: &TestReportInFilesystem, /* path in */ sl@0: &TestReportDupInternalRep, sl@0: &TestReportFreeInternalRep, sl@0: NULL, /* native to norm */ sl@0: NULL, /* convert to native */ sl@0: &TestReportNormalizePath, sl@0: NULL, /* path type */ sl@0: NULL, /* separator */ sl@0: &TestReportStat, sl@0: &TestReportAccess, sl@0: &TestReportOpenFileChannel, sl@0: &TestReportMatchInDirectory, sl@0: &TestReportUtime, sl@0: &TestReportLink, sl@0: NULL /* list volumes */, sl@0: &TestReportFileAttrStrings, sl@0: &TestReportFileAttrsGet, sl@0: &TestReportFileAttrsSet, sl@0: &TestReportCreateDirectory, sl@0: &TestReportRemoveDirectory, sl@0: &TestReportDeleteFile, sl@0: &TestReportCopyFile, sl@0: &TestReportRenameFile, sl@0: &TestReportCopyDirectory, sl@0: &TestReportLstat, sl@0: &TestReportLoadFile, sl@0: NULL /* cwd */, sl@0: &TestReportChdir sl@0: }; sl@0: sl@0: static Tcl_Filesystem simpleFilesystem = { sl@0: "simple", sl@0: sizeof(Tcl_Filesystem), sl@0: TCL_FILESYSTEM_VERSION_1, sl@0: &SimplePathInFilesystem, sl@0: NULL, sl@0: NULL, sl@0: /* No internal to normalized, since we don't create any sl@0: * pure 'internal' Tcl_Obj path representations */ sl@0: NULL, sl@0: /* No create native rep function, since we don't use it sl@0: * or 'Tcl_FSNewNativePath' */ sl@0: NULL, sl@0: /* Normalize path isn't needed - we assume paths only have sl@0: * one representation */ sl@0: NULL, sl@0: NULL, sl@0: NULL, sl@0: &SimpleStat, sl@0: &SimpleAccess, sl@0: &SimpleOpenFileChannel, sl@0: NULL, sl@0: NULL, sl@0: /* We choose not to support symbolic links inside our vfs's */ sl@0: NULL, sl@0: &SimpleListVolumes, sl@0: NULL, sl@0: NULL, sl@0: NULL, sl@0: NULL, sl@0: NULL, sl@0: NULL, sl@0: /* No copy file - fallback will occur at Tcl level */ sl@0: NULL, sl@0: /* No rename file - fallback will occur at Tcl level */ sl@0: NULL, sl@0: /* No copy directory - fallback will occur at Tcl level */ sl@0: NULL, sl@0: /* Use stat for lstat */ sl@0: NULL, sl@0: /* No load - fallback on core implementation */ sl@0: NULL, sl@0: /* We don't need a getcwd or chdir - fallback on Tcl's versions */ sl@0: NULL, sl@0: NULL sl@0: }; sl@0: sl@0: sl@0: /* sl@0: * External (platform specific) initialization routine, these declarations sl@0: * explicitly don't use EXTERN since this code does not get compiled sl@0: * into the library: sl@0: */ sl@0: sl@0: extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); sl@0: extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcltest_Init -- sl@0: * sl@0: * This procedure performs application-specific initialization. sl@0: * Most applications, especially those that incorporate additional sl@0: * packages, will have their own version of this procedure. sl@0: * sl@0: * Results: sl@0: * Returns a standard Tcl completion code, and leaves an error sl@0: * message in the interp's result if an error occurs. sl@0: * sl@0: * Side effects: sl@0: * Depends on the startup script. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcltest_Init(interp) sl@0: Tcl_Interp *interp; /* Interpreter for application. */ sl@0: { sl@0: Tcl_ValueType t3ArgTypes[2]; sl@0: sl@0: Tcl_Obj *listPtr; sl@0: Tcl_Obj **objv; sl@0: int objc, index; sl@0: static CONST char *specialOptions[] = { sl@0: "-appinitprocerror", "-appinitprocdeleteinterp", sl@0: "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL sl@0: }; sl@0: sl@0: #ifndef TCL_TIP268 sl@0: if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { sl@0: #else sl@0: /* TIP #268: Full patchlevel instead of just major.minor */ sl@0: if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { sl@0: #endif sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Create additional commands and math functions for testing Tcl. sl@0: */ sl@0: sl@0: Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", sl@0: TestGetIndexFromObjStructObjCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_DStringInit(&dstring); sl@0: Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); sl@0: Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testgetvarfullname", sl@0: TestgetvarfullnameCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testopenfilechannelproc", sl@0: TestopenfilechannelprocCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testseterr", TestsetCmd, sl@0: (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testsetobjerrorcode", sl@0: TestsetobjerrorcodeCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateObjCommand(interp, "testnumutfchars", sl@0: TestNumUtfCharsCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, sl@0: (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testtranslatefilename", sl@0: TesttranslatefilenameCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, sl@0: (ClientData) 123); sl@0: Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, sl@0: (ClientData) 345); sl@0: Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, sl@0: (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); sl@0: Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, sl@0: (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); sl@0: t3ArgTypes[0] = TCL_EITHER; sl@0: t3ArgTypes[1] = TCL_EITHER; sl@0: Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, sl@0: (ClientData) 0); sl@0: sl@0: #ifdef TCL_THREADS sl@0: if (TclThread_Init(interp) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: * Check for special options used in ../tests/main.test sl@0: */ sl@0: sl@0: listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); sl@0: if (listPtr != NULL) { sl@0: if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, sl@0: TCL_EXACT, &index) == TCL_OK)) { sl@0: switch (index) { sl@0: case 0: { sl@0: return TCL_ERROR; sl@0: } sl@0: case 1: { sl@0: Tcl_DeleteInterp(interp); sl@0: return TCL_ERROR; sl@0: } sl@0: case 2: { sl@0: int mode; sl@0: Tcl_UnregisterChannel(interp, sl@0: Tcl_GetChannel(interp, "stderr", &mode)); sl@0: return TCL_ERROR; sl@0: } sl@0: case 3: { sl@0: if (objc-1) { sl@0: Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, sl@0: objv[1], TCL_GLOBAL_ONLY); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * And finally add any platform specific test commands. sl@0: */ sl@0: sl@0: return TclplatformtestInit(interp); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestasyncCmd -- sl@0: * sl@0: * This procedure implements the "testasync" command. It is used sl@0: * to test the asynchronous handler facilities of Tcl. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates, deletes, and invokes handlers. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestasyncCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: TestAsyncHandler *asyncPtr, *prevPtr; sl@0: int id, code; sl@0: static int nextId = 1; sl@0: char buf[TCL_INTEGER_SPACE]; sl@0: sl@0: if (argc < 2) { sl@0: wrongNumArgs: sl@0: Tcl_SetResult(interp, "wrong # args", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: if (argc != 3) { sl@0: goto wrongNumArgs; sl@0: } sl@0: asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); sl@0: asyncPtr->id = nextId; sl@0: nextId++; sl@0: asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, sl@0: (ClientData) asyncPtr); sl@0: asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); sl@0: strcpy(asyncPtr->command, argv[2]); sl@0: asyncPtr->nextPtr = firstHandler; sl@0: firstHandler = asyncPtr; sl@0: TclFormatInt(buf, asyncPtr->id); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: if (argc == 2) { sl@0: while (firstHandler != NULL) { sl@0: asyncPtr = firstHandler; sl@0: firstHandler = asyncPtr->nextPtr; sl@0: Tcl_AsyncDelete(asyncPtr->handler); sl@0: ckfree(asyncPtr->command); sl@0: ckfree((char *) asyncPtr); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: if (argc != 3) { sl@0: goto wrongNumArgs; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; sl@0: prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { sl@0: if (asyncPtr->id != id) { sl@0: continue; sl@0: } sl@0: if (prevPtr == NULL) { sl@0: firstHandler = asyncPtr->nextPtr; sl@0: } else { sl@0: prevPtr->nextPtr = asyncPtr->nextPtr; sl@0: } sl@0: Tcl_AsyncDelete(asyncPtr->handler); sl@0: ckfree(asyncPtr->command); sl@0: ckfree((char *) asyncPtr); sl@0: break; sl@0: } sl@0: } else if (strcmp(argv[1], "mark") == 0) { sl@0: if (argc != 5) { sl@0: goto wrongNumArgs; sl@0: } sl@0: if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) sl@0: || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: for (asyncPtr = firstHandler; asyncPtr != NULL; sl@0: asyncPtr = asyncPtr->nextPtr) { sl@0: if (asyncPtr->id == id) { sl@0: Tcl_AsyncMark(asyncPtr->handler); sl@0: break; sl@0: } sl@0: } sl@0: Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); sl@0: return code; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be create, delete, int, or mark", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: AsyncHandlerProc(clientData, interp, code) sl@0: ClientData clientData; /* Pointer to TestAsyncHandler structure. */ sl@0: Tcl_Interp *interp; /* Interpreter in which command was sl@0: * executed, or NULL. */ sl@0: int code; /* Current return code from command. */ sl@0: { sl@0: TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; sl@0: CONST char *listArgv[4], *cmd; sl@0: char string[TCL_INTEGER_SPACE]; sl@0: sl@0: TclFormatInt(string, code); sl@0: listArgv[0] = asyncPtr->command; sl@0: listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); sl@0: listArgv[2] = string; sl@0: listArgv[3] = NULL; sl@0: cmd = Tcl_Merge(3, listArgv); sl@0: if (interp != NULL) { sl@0: code = Tcl_Eval(interp, cmd); sl@0: } else { sl@0: /* sl@0: * this should not happen, but by definition of how async sl@0: * handlers are invoked, it's possible. Better error sl@0: * checking is needed here. sl@0: */ sl@0: } sl@0: ckfree((char *)cmd); sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestcmdinfoCmd -- sl@0: * sl@0: * This procedure implements the "testcmdinfo" command. It is used sl@0: * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation sl@0: * and deletion. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes various commands and modifies their data. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestcmdinfoCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_CmdInfo info; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option cmdName\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", sl@0: CmdDelProc1); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: Tcl_DStringInit(&delString); sl@0: Tcl_DeleteCommand(interp, argv[2]); sl@0: Tcl_DStringResult(interp, &delString); sl@0: } else if (strcmp(argv[1], "get") == 0) { sl@0: if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { sl@0: Tcl_SetResult(interp, "??", TCL_STATIC); sl@0: return TCL_OK; sl@0: } sl@0: if (info.proc == CmdProc1) { sl@0: Tcl_AppendResult(interp, "CmdProc1", " ", sl@0: (char *) info.clientData, (char *) NULL); sl@0: } else if (info.proc == CmdProc2) { sl@0: Tcl_AppendResult(interp, "CmdProc2", " ", sl@0: (char *) info.clientData, (char *) NULL); sl@0: } else { sl@0: Tcl_AppendResult(interp, "unknown", (char *) NULL); sl@0: } sl@0: if (info.deleteProc == CmdDelProc1) { sl@0: Tcl_AppendResult(interp, " CmdDelProc1", " ", sl@0: (char *) info.deleteData, (char *) NULL); sl@0: } else if (info.deleteProc == CmdDelProc2) { sl@0: Tcl_AppendResult(interp, " CmdDelProc2", " ", sl@0: (char *) info.deleteData, (char *) NULL); sl@0: } else { sl@0: Tcl_AppendResult(interp, " unknown", (char *) NULL); sl@0: } sl@0: Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, sl@0: (char *) NULL); sl@0: if (info.isNativeObjectProc) { sl@0: Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL); sl@0: } else { sl@0: Tcl_AppendResult(interp, " stringProc", (char *) NULL); sl@0: } sl@0: } else if (strcmp(argv[1], "modify") == 0) { sl@0: info.proc = CmdProc2; sl@0: info.clientData = (ClientData) "new_command_data"; sl@0: info.objProc = NULL; sl@0: info.objClientData = (ClientData) NULL; sl@0: info.deleteProc = CmdDelProc2; sl@0: info.deleteData = (ClientData) "new_delete_data"; sl@0: if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { sl@0: Tcl_SetResult(interp, "0", TCL_STATIC); sl@0: } else { sl@0: Tcl_SetResult(interp, "1", TCL_STATIC); sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be create, delete, get, or modify", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /*ARGSUSED*/ sl@0: static int sl@0: CmdProc1(clientData, interp, argc, argv) sl@0: ClientData clientData; /* String to return. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, sl@0: (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /*ARGSUSED*/ sl@0: static int sl@0: CmdProc2(clientData, interp, argc, argv) sl@0: ClientData clientData; /* String to return. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, sl@0: (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static void sl@0: CmdDelProc1(clientData) sl@0: ClientData clientData; /* String to save. */ sl@0: { sl@0: Tcl_DStringInit(&delString); sl@0: Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); sl@0: Tcl_DStringAppend(&delString, (char *) clientData, -1); sl@0: } sl@0: sl@0: static void sl@0: CmdDelProc2(clientData) sl@0: ClientData clientData; /* String to save. */ sl@0: { sl@0: Tcl_DStringInit(&delString); sl@0: Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); sl@0: Tcl_DStringAppend(&delString, (char *) clientData, -1); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestcmdtokenCmd -- sl@0: * sl@0: * This procedure implements the "testcmdtoken" command. It is used sl@0: * to test Tcl_Command tokens and procedures such as sl@0: * Tcl_GetCommandFullName. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes various commands and modifies their data. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestcmdtokenCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_Command token; sl@0: int *l; sl@0: char buf[30]; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option arg\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: token = Tcl_CreateCommand(interp, argv[2], CmdProc1, sl@0: (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); sl@0: sprintf(buf, "%p", (VOID *)token); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } else if (strcmp(argv[1], "name") == 0) { sl@0: Tcl_Obj *objPtr; sl@0: sl@0: if (sscanf(argv[2], "%p", &l) != 1) { sl@0: Tcl_AppendResult(interp, "bad command token \"", argv[2], sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: objPtr = Tcl_NewObj(); sl@0: Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); sl@0: sl@0: Tcl_AppendElement(interp, sl@0: Tcl_GetCommandName(interp, (Tcl_Command) l)); sl@0: Tcl_AppendElement(interp, Tcl_GetString(objPtr)); sl@0: Tcl_DecrRefCount(objPtr); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be create or name", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestcmdtraceCmd -- sl@0: * sl@0: * This procedure implements the "testcmdtrace" command. It is used sl@0: * to test Tcl_CreateTrace and Tcl_DeleteTrace. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes a command trace, and tests the invocation of sl@0: * a procedure by the command trace. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestcmdtraceCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_DString buffer; sl@0: int result; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option script\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[1], "tracetest") == 0) { sl@0: Tcl_DStringInit(&buffer); sl@0: cmdTrace = Tcl_CreateTrace(interp, 50000, sl@0: (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); sl@0: result = Tcl_Eval(interp, argv[2]); sl@0: if (result == TCL_OK) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); sl@0: } sl@0: Tcl_DeleteTrace(interp, cmdTrace); sl@0: Tcl_DStringFree(&buffer); sl@0: } else if (strcmp(argv[1], "deletetest") == 0) { sl@0: /* sl@0: * Create a command trace then eval a script to check whether it is sl@0: * called. Note that this trace procedure removes itself as a sl@0: * further check of the robustness of the trace proc calling code in sl@0: * TclExecuteByteCode. sl@0: */ sl@0: sl@0: cmdTrace = Tcl_CreateTrace(interp, 50000, sl@0: (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); sl@0: Tcl_Eval(interp, argv[2]); sl@0: } else if (strcmp(argv[1], "leveltest") == 0) { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_DStringInit(&buffer); sl@0: cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, sl@0: (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); sl@0: result = Tcl_Eval(interp, argv[2]); sl@0: if (result == TCL_OK) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); sl@0: } sl@0: Tcl_DeleteTrace(interp, cmdTrace); sl@0: Tcl_DStringFree(&buffer); sl@0: } else if ( strcmp(argv[1], "resulttest" ) == 0 ) { sl@0: /* Create an object-based trace, then eval a script. This is used sl@0: * to test return codes other than TCL_OK from the trace engine. sl@0: */ sl@0: static int deleteCalled; sl@0: deleteCalled = 0; sl@0: cmdTrace = Tcl_CreateObjTrace( interp, 50000, sl@0: TCL_ALLOW_INLINE_COMPILATION, sl@0: ObjTraceProc, sl@0: (ClientData) &deleteCalled, sl@0: ObjTraceDeleteProc ); sl@0: result = Tcl_Eval( interp, argv[ 2 ] ); sl@0: Tcl_DeleteTrace( interp, cmdTrace ); sl@0: if ( !deleteCalled ) { sl@0: Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC ); sl@0: return TCL_ERROR; sl@0: } else { sl@0: return result; sl@0: } sl@0: sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be tracetest, deletetest or resulttest", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static void sl@0: CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, sl@0: argc, argv) sl@0: ClientData clientData; /* Pointer to buffer in which the sl@0: * command and arguments are appended. sl@0: * Accumulates test result. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int level; /* Current trace level. */ sl@0: char *command; /* The command being traced (after sl@0: * substitutions). */ sl@0: Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ sl@0: ClientData cmdClientData; /* Client data associated with command sl@0: * procedure. */ sl@0: int argc; /* Number of arguments. */ sl@0: char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_DString *bufPtr = (Tcl_DString *) clientData; sl@0: int i; sl@0: sl@0: Tcl_DStringAppendElement(bufPtr, command); sl@0: sl@0: Tcl_DStringStartSublist(bufPtr); sl@0: for (i = 0; i < argc; i++) { sl@0: Tcl_DStringAppendElement(bufPtr, argv[i]); sl@0: } sl@0: Tcl_DStringEndSublist(bufPtr); sl@0: } sl@0: sl@0: static void sl@0: CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, sl@0: cmdClientData, argc, argv) sl@0: ClientData clientData; /* Unused. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int level; /* Current trace level. */ sl@0: char *command; /* The command being traced (after sl@0: * substitutions). */ sl@0: Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ sl@0: ClientData cmdClientData; /* Client data associated with command sl@0: * procedure. */ sl@0: int argc; /* Number of arguments. */ sl@0: char **argv; /* Argument strings. */ sl@0: { sl@0: /* sl@0: * Remove ourselves to test whether calling Tcl_DeleteTrace within sl@0: * a trace callback causes the for loop in TclExecuteByteCode that sl@0: * calls traces to reference freed memory. sl@0: */ sl@0: sl@0: Tcl_DeleteTrace(interp, cmdTrace); sl@0: } sl@0: sl@0: static int sl@0: ObjTraceProc( clientData, interp, level, command, token, objc, objv ) sl@0: ClientData clientData; /* unused */ sl@0: Tcl_Interp* interp; /* Tcl interpreter */ sl@0: int level; /* Execution level */ sl@0: CONST char* command; /* Command being executed */ sl@0: Tcl_Command token; /* Command information */ sl@0: int objc; /* Parameter count */ sl@0: Tcl_Obj *CONST objv[]; /* Parameter list */ sl@0: { sl@0: CONST char* word = Tcl_GetString( objv[ 0 ] ); sl@0: if ( !strcmp( word, "Error" ) ) { sl@0: Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) ); sl@0: return TCL_ERROR; sl@0: } else if ( !strcmp( word, "Break" ) ) { sl@0: return TCL_BREAK; sl@0: } else if ( !strcmp( word, "Continue" ) ) { sl@0: return TCL_CONTINUE; sl@0: } else if ( !strcmp( word, "Return" ) ) { sl@0: return TCL_RETURN; sl@0: } else if ( !strcmp( word, "OtherStatus" ) ) { sl@0: return 6; sl@0: } else { sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: static void sl@0: ObjTraceDeleteProc( clientData ) sl@0: ClientData clientData; sl@0: { sl@0: int * intPtr = (int *) clientData; sl@0: *intPtr = 1; /* Record that the trace was deleted */ sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestcreatecommandCmd -- sl@0: * sl@0: * This procedure implements the "testcreatecommand" command. It is sl@0: * used to test that the Tcl_CreateCommand creates a new command in sl@0: * the namespace specified as part of its name, if any. It also sl@0: * checks that the namespace code ignore single ":"s in the middle sl@0: * or end of a command name. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes two commands ("test_ns_basic::createdcommand" sl@0: * and "value:at:"). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestcreatecommandCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", sl@0: CreatedCommandProc, (ClientData) NULL, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand"); sl@0: } else if (strcmp(argv[1], "create2") == 0) { sl@0: Tcl_CreateCommand(interp, "value:at:", sl@0: CreatedCommandProc2, (ClientData) NULL, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: } else if (strcmp(argv[1], "delete2") == 0) { sl@0: Tcl_DeleteCommand(interp, "value:at:"); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be create, delete, create2, or delete2", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: CreatedCommandProc(clientData, interp, argc, argv) sl@0: ClientData clientData; /* String to return. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_CmdInfo info; sl@0: int found; sl@0: sl@0: found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", sl@0: &info); sl@0: if (!found) { sl@0: Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendResult(interp, "CreatedCommandProc in ", sl@0: info.namespacePtr->fullName, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: CreatedCommandProc2(clientData, interp, argc, argv) sl@0: ClientData clientData; /* String to return. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_CmdInfo info; sl@0: int found; sl@0: sl@0: found = Tcl_GetCommandInfo(interp, "value:at:", &info); sl@0: if (!found) { sl@0: Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendResult(interp, "CreatedCommandProc2 in ", sl@0: info.namespacePtr->fullName, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestdcallCmd -- sl@0: * sl@0: * This procedure implements the "testdcall" command. It is used sl@0: * to test Tcl_CallWhenDeleted. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes interpreters. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestdcallCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int i, id; sl@0: sl@0: delInterp = Tcl_CreateInterp(); sl@0: Tcl_DStringInit(&delString); sl@0: for (i = 1; i < argc; i++) { sl@0: if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (id < 0) { sl@0: Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, sl@0: (ClientData) (-id)); sl@0: } else { sl@0: Tcl_CallWhenDeleted(delInterp, DelCallbackProc, sl@0: (ClientData) id); sl@0: } sl@0: } sl@0: Tcl_DeleteInterp(delInterp); sl@0: Tcl_DStringResult(interp, &delString); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * The deletion callback used by TestdcallCmd: sl@0: */ sl@0: sl@0: static void sl@0: DelCallbackProc(clientData, interp) sl@0: ClientData clientData; /* Numerical value to append to sl@0: * delString. */ sl@0: Tcl_Interp *interp; /* Interpreter being deleted. */ sl@0: { sl@0: int id = (int) clientData; sl@0: char buffer[TCL_INTEGER_SPACE]; sl@0: sl@0: TclFormatInt(buffer, id); sl@0: Tcl_DStringAppendElement(&delString, buffer); sl@0: if (interp != delInterp) { sl@0: Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestdelCmd -- sl@0: * sl@0: * This procedure implements the "testdcall" command. It is used sl@0: * to test Tcl_CallWhenDeleted. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes interpreters. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestdelCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: DelCmd *dPtr; sl@0: Tcl_Interp *slave; sl@0: sl@0: if (argc != 4) { sl@0: Tcl_SetResult(interp, "wrong # args", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: slave = Tcl_GetSlave(interp, argv[1]); sl@0: if (slave == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); sl@0: dPtr->interp = interp; sl@0: dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); sl@0: strcpy(dPtr->deleteCmd, argv[3]); sl@0: sl@0: Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, sl@0: DelDeleteProc); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: DelCmdProc(clientData, interp, argc, argv) sl@0: ClientData clientData; /* String result to return. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: DelCmd *dPtr = (DelCmd *) clientData; sl@0: sl@0: Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); sl@0: ckfree(dPtr->deleteCmd); sl@0: ckfree((char *) dPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static void sl@0: DelDeleteProc(clientData) sl@0: ClientData clientData; /* String command to evaluate. */ sl@0: { sl@0: DelCmd *dPtr = (DelCmd *) clientData; sl@0: sl@0: Tcl_Eval(dPtr->interp, dPtr->deleteCmd); sl@0: Tcl_ResetResult(dPtr->interp); sl@0: ckfree(dPtr->deleteCmd); sl@0: ckfree((char *) dPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestdelassocdataCmd -- sl@0: * sl@0: * This procedure implements the "testdelassocdata" command. It is used sl@0: * to test Tcl_DeleteAssocData. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Deletes an association between a key and associated data from an sl@0: * interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestdelassocdataCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " data_key\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DeleteAssocData(interp, argv[1]); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestdstringCmd -- sl@0: * sl@0: * This procedure implements the "testdstring" command. It is used sl@0: * to test the dynamic string facilities of Tcl. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates, deletes, and invokes handlers. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestdstringCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int count; sl@0: sl@0: if (argc < 2) { sl@0: wrongNumArgs: sl@0: Tcl_SetResult(interp, "wrong # args", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "append") == 0) { sl@0: if (argc != 4) { sl@0: goto wrongNumArgs; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringAppend(&dstring, argv[2], count); sl@0: } else if (strcmp(argv[1], "element") == 0) { sl@0: if (argc != 3) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_DStringAppendElement(&dstring, argv[2]); sl@0: } else if (strcmp(argv[1], "end") == 0) { sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_DStringEndSublist(&dstring); sl@0: } else if (strcmp(argv[1], "free") == 0) { sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_DStringFree(&dstring); sl@0: } else if (strcmp(argv[1], "get") == 0) { sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE); sl@0: } else if (strcmp(argv[1], "gresult") == 0) { sl@0: if (argc != 3) { sl@0: goto wrongNumArgs; sl@0: } sl@0: if (strcmp(argv[2], "staticsmall") == 0) { sl@0: Tcl_SetResult(interp, "short", TCL_STATIC); sl@0: } else if (strcmp(argv[2], "staticlarge") == 0) { sl@0: Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); sl@0: } else if (strcmp(argv[2], "free") == 0) { sl@0: Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC); sl@0: strcpy(interp->result, "This is a malloc-ed string"); sl@0: } else if (strcmp(argv[2], "special") == 0) { sl@0: interp->result = (char *) ckalloc(100); sl@0: interp->result += 4; sl@0: interp->freeProc = SpecialFree; sl@0: strcpy(interp->result, "This is a specially-allocated string"); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad gresult option \"", argv[2], sl@0: "\": must be staticsmall, staticlarge, free, or special", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringGetResult(interp, &dstring); sl@0: } else if (strcmp(argv[1], "length") == 0) { sl@0: char buf[TCL_INTEGER_SPACE]; sl@0: sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: TclFormatInt(buf, Tcl_DStringLength(&dstring)); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } else if (strcmp(argv[1], "result") == 0) { sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_DStringResult(interp, &dstring); sl@0: } else if (strcmp(argv[1], "trunc") == 0) { sl@0: if (argc != 3) { sl@0: goto wrongNumArgs; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringTrunc(&dstring, count); sl@0: } else if (strcmp(argv[1], "start") == 0) { sl@0: if (argc != 2) { sl@0: goto wrongNumArgs; sl@0: } sl@0: Tcl_DStringStartSublist(&dstring); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be append, element, end, free, get, length, ", sl@0: "result, trunc, or start", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * The procedure below is used as a special freeProc to test how well sl@0: * Tcl_DStringGetResult handles freeProc's other than free. sl@0: */ sl@0: sl@0: static void SpecialFree(blockPtr) sl@0: char *blockPtr; /* Block to free. */ sl@0: { sl@0: ckfree(blockPtr - 4); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestencodingCmd -- sl@0: * sl@0: * This procedure implements the "testencoding" command. It is used sl@0: * to test the encoding package. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Load encodings. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestencodingObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Encoding encoding; sl@0: int index, length; sl@0: char *string; sl@0: TclEncoding *encodingPtr; sl@0: static CONST char *optionStrings[] = { sl@0: "create", "delete", "path", sl@0: NULL sl@0: }; sl@0: enum options { sl@0: ENC_CREATE, ENC_DELETE, ENC_PATH sl@0: }; sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: switch ((enum options) index) { sl@0: case ENC_CREATE: { sl@0: Tcl_EncodingType type; sl@0: sl@0: if (objc != 5) { sl@0: return TCL_ERROR; sl@0: } sl@0: encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); sl@0: encodingPtr->interp = interp; sl@0: sl@0: string = Tcl_GetStringFromObj(objv[3], &length); sl@0: encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); sl@0: memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); sl@0: sl@0: string = Tcl_GetStringFromObj(objv[4], &length); sl@0: encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); sl@0: memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); sl@0: sl@0: string = Tcl_GetStringFromObj(objv[2], &length); sl@0: sl@0: type.encodingName = string; sl@0: type.toUtfProc = EncodingToUtfProc; sl@0: type.fromUtfProc = EncodingFromUtfProc; sl@0: type.freeProc = EncodingFreeProc; sl@0: type.clientData = (ClientData) encodingPtr; sl@0: type.nullSize = 1; sl@0: sl@0: Tcl_CreateEncoding(&type); sl@0: break; sl@0: } sl@0: case ENC_DELETE: { sl@0: if (objc != 3) { sl@0: return TCL_ERROR; sl@0: } sl@0: encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); sl@0: Tcl_FreeEncoding(encoding); sl@0: Tcl_FreeEncoding(encoding); sl@0: break; sl@0: } sl@0: case ENC_PATH: { sl@0: if (objc == 2) { sl@0: Tcl_SetObjResult(interp, TclGetLibraryPath()); sl@0: } else { sl@0: TclSetLibraryPath(objv[2]); sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: static int sl@0: EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, sl@0: srcReadPtr, dstWrotePtr, dstCharsPtr) sl@0: ClientData clientData; /* TclEncoding structure. */ sl@0: CONST char *src; /* Source string in specified encoding. */ sl@0: int srcLen; /* Source string length in bytes. */ sl@0: int flags; /* Conversion control flags. */ sl@0: Tcl_EncodingState *statePtr;/* Current state. */ sl@0: char *dst; /* Output buffer. */ sl@0: int dstLen; /* The maximum length of output buffer. */ sl@0: int *srcReadPtr; /* Filled with number of bytes read. */ sl@0: int *dstWrotePtr; /* Filled with number of bytes stored. */ sl@0: int *dstCharsPtr; /* Filled with number of chars stored. */ sl@0: { sl@0: int len; sl@0: TclEncoding *encodingPtr; sl@0: sl@0: encodingPtr = (TclEncoding *) clientData; sl@0: Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); sl@0: sl@0: len = strlen(Tcl_GetStringResult(encodingPtr->interp)); sl@0: if (len > dstLen) { sl@0: len = dstLen; sl@0: } sl@0: memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); sl@0: Tcl_ResetResult(encodingPtr->interp); sl@0: sl@0: *srcReadPtr = srcLen; sl@0: *dstWrotePtr = len; sl@0: *dstCharsPtr = len; sl@0: return TCL_OK; sl@0: } sl@0: static int sl@0: EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, sl@0: srcReadPtr, dstWrotePtr, dstCharsPtr) sl@0: ClientData clientData; /* TclEncoding structure. */ sl@0: CONST char *src; /* Source string in specified encoding. */ sl@0: int srcLen; /* Source string length in bytes. */ sl@0: int flags; /* Conversion control flags. */ sl@0: Tcl_EncodingState *statePtr;/* Current state. */ sl@0: char *dst; /* Output buffer. */ sl@0: int dstLen; /* The maximum length of output buffer. */ sl@0: int *srcReadPtr; /* Filled with number of bytes read. */ sl@0: int *dstWrotePtr; /* Filled with number of bytes stored. */ sl@0: int *dstCharsPtr; /* Filled with number of chars stored. */ sl@0: { sl@0: int len; sl@0: TclEncoding *encodingPtr; sl@0: sl@0: encodingPtr = (TclEncoding *) clientData; sl@0: Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); sl@0: sl@0: len = strlen(Tcl_GetStringResult(encodingPtr->interp)); sl@0: if (len > dstLen) { sl@0: len = dstLen; sl@0: } sl@0: memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); sl@0: Tcl_ResetResult(encodingPtr->interp); sl@0: sl@0: *srcReadPtr = srcLen; sl@0: *dstWrotePtr = len; sl@0: *dstCharsPtr = len; sl@0: return TCL_OK; sl@0: } sl@0: static void sl@0: EncodingFreeProc(clientData) sl@0: ClientData clientData; /* ClientData associated with type. */ sl@0: { sl@0: TclEncoding *encodingPtr; sl@0: sl@0: encodingPtr = (TclEncoding *) clientData; sl@0: ckfree((char *) encodingPtr->toUtfCmd); sl@0: ckfree((char *) encodingPtr->fromUtfCmd); sl@0: ckfree((char *) encodingPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestevalexObjCmd -- sl@0: * sl@0: * This procedure implements the "testevalex" command. It is sl@0: * used to test Tcl_EvalEx. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestevalexObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int code, oldFlags, length, flags; sl@0: char *string; sl@0: sl@0: if (objc == 1) { sl@0: /* sl@0: * The command was invoked with no arguments, so just toggle sl@0: * the flag that determines whether we use Tcl_EvalEx. sl@0: */ sl@0: sl@0: if (iPtr->flags & USE_EVAL_DIRECT) { sl@0: iPtr->flags &= ~USE_EVAL_DIRECT; sl@0: Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC); sl@0: } else { sl@0: iPtr->flags |= USE_EVAL_DIRECT; sl@0: Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: flags = 0; sl@0: if (objc == 3) { sl@0: string = Tcl_GetStringFromObj(objv[2], &length); sl@0: if (strcmp(string, "global") != 0) { sl@0: Tcl_AppendResult(interp, "bad value \"", string, sl@0: "\": must be global", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: flags = TCL_EVAL_GLOBAL; sl@0: } else if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "script ?global?"); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetResult(interp, "xxx", TCL_STATIC); sl@0: sl@0: /* sl@0: * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter sl@0: * in addition to calling Tcl_EvalEx. This is needed so that even nested sl@0: * commands are evaluated directly. sl@0: */ sl@0: sl@0: oldFlags = iPtr->flags; sl@0: iPtr->flags |= USE_EVAL_DIRECT; sl@0: string = Tcl_GetStringFromObj(objv[1], &length); sl@0: code = Tcl_EvalEx(interp, string, length, flags); sl@0: iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT) sl@0: | (oldFlags & USE_EVAL_DIRECT); sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestevalobjvObjCmd -- sl@0: * sl@0: * This procedure implements the "testevalobjv" command. It is sl@0: * used to test Tcl_EvalObjv. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestevalobjvObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int evalGlobal; sl@0: sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: return Tcl_EvalObjv(interp, objc-2, objv+2, sl@0: (evalGlobal) ? TCL_EVAL_GLOBAL : 0); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TesteventObjCmd -- sl@0: * sl@0: * This procedure implements a 'testevent' command. The command sl@0: * is used to test event queue management. sl@0: * sl@0: * The command takes two forms: sl@0: * - testevent queue name position script sl@0: * Queues an event at the given position in the queue, and sl@0: * associates a given name with it (the same name may be sl@0: * associated with multiple events). When the event comes sl@0: * to the head of the queue, executes the given script at sl@0: * global level in the current interp. The position may be sl@0: * one of 'head', 'tail' or 'mark'. sl@0: * - testevent delete name sl@0: * Deletes any events associated with the given name from sl@0: * the queue. sl@0: * sl@0: * Return value: sl@0: * Returns a standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Manipulates the event queue as directed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TesteventObjCmd( ClientData unused, /* Not used */ sl@0: Tcl_Interp* interp, /* Tcl interpreter */ sl@0: int objc, /* Parameter count */ sl@0: Tcl_Obj *CONST objv[] ) /* Parameter vector */ sl@0: { sl@0: sl@0: static CONST char* subcommands[] = { /* Possible subcommands */ sl@0: "queue", sl@0: "delete", sl@0: NULL sl@0: }; sl@0: int subCmdIndex; /* Index of the chosen subcommand */ sl@0: static CONST char* positions[] = { /* Possible queue positions */ sl@0: "head", sl@0: "tail", sl@0: "mark", sl@0: NULL sl@0: }; sl@0: int posIndex; /* Index of the chosen position */ sl@0: static CONST Tcl_QueuePosition posNum[] = { sl@0: /* Interpretation of the chosen position */ sl@0: TCL_QUEUE_HEAD, sl@0: TCL_QUEUE_TAIL, sl@0: TCL_QUEUE_MARK sl@0: }; sl@0: TestEvent* ev; /* Event to be queued */ sl@0: sl@0: if ( objc < 2 ) { sl@0: Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" ); sl@0: return TCL_ERROR; sl@0: } sl@0: if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand", sl@0: TCL_EXACT, &subCmdIndex ) != TCL_OK ) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ( subCmdIndex ) { sl@0: case 0: /* queue */ sl@0: if ( objc != 5 ) { sl@0: Tcl_WrongNumArgs( interp, 2, objv, "name position script" ); sl@0: return TCL_ERROR; sl@0: } sl@0: if ( Tcl_GetIndexFromObj( interp, objv[3], positions, sl@0: "position specifier", TCL_EXACT, sl@0: &posIndex ) != TCL_OK ) { sl@0: return TCL_ERROR; sl@0: } sl@0: ev = (TestEvent*) ckalloc( sizeof( TestEvent ) ); sl@0: ev->header.proc = TesteventProc; sl@0: ev->header.nextPtr = NULL; sl@0: ev->interp = interp; sl@0: ev->command = objv[ 4 ]; sl@0: Tcl_IncrRefCount( ev->command ); sl@0: ev->tag = objv[ 2 ]; sl@0: Tcl_IncrRefCount( ev->tag ); sl@0: Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] ); sl@0: break; sl@0: sl@0: case 1: /* delete */ sl@0: if ( objc != 3 ) { sl@0: Tcl_WrongNumArgs( interp, 2, objv, "name" ); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] ); sl@0: break; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TesteventProc -- sl@0: * sl@0: * Delivers a test event to the Tcl interpreter as part of event sl@0: * queue testing. sl@0: * sl@0: * Results: sl@0: * Returns 1 if the event has been serviced, 0 otherwise. sl@0: * sl@0: * Side effects: sl@0: * Evaluates the event's callback script, so has whatever sl@0: * side effects the callback has. The return value of the sl@0: * callback script becomes the return value of this function. sl@0: * If the callback script reports an error, it is reported as sl@0: * a background error. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TesteventProc( Tcl_Event* event, /* Event to deliver */ sl@0: int flags ) /* Current flags for Tcl_ServiceEvent */ sl@0: { sl@0: TestEvent * ev = (TestEvent *) event; sl@0: Tcl_Interp* interp = ev->interp; sl@0: Tcl_Obj* command = ev->command; sl@0: int result = Tcl_EvalObjEx( interp, command, sl@0: TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT ); sl@0: int retval; sl@0: if ( result != TCL_OK ) { sl@0: Tcl_AddErrorInfo( interp, sl@0: " (command bound to \"testevent\" callback)" ); sl@0: Tcl_BackgroundError( interp ); sl@0: return 1; /* Avoid looping on errors */ sl@0: } sl@0: if ( Tcl_GetBooleanFromObj( interp, sl@0: Tcl_GetObjResult( interp ), sl@0: &retval ) != TCL_OK ) { sl@0: Tcl_AddErrorInfo( interp, sl@0: " (return value from \"testevent\" callback)" ); sl@0: Tcl_BackgroundError( interp ); sl@0: return 1; sl@0: } sl@0: if ( retval ) { sl@0: Tcl_DecrRefCount( ev->tag ); sl@0: Tcl_DecrRefCount( ev->command ); sl@0: } sl@0: sl@0: return retval; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TesteventDeleteProc -- sl@0: * sl@0: * Removes some set of events from the queue. sl@0: * sl@0: * This procedure is used as part of testing event queue management. sl@0: * sl@0: * Results: sl@0: * Returns 1 if a given event should be deleted, 0 otherwise. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TesteventDeleteProc( Tcl_Event* event, /* Event to examine */ sl@0: ClientData clientData ) /* Tcl_Obj containing the name sl@0: * of the event(s) to remove */ sl@0: { sl@0: TestEvent* ev; /* Event to examine */ sl@0: char* evNameStr; sl@0: Tcl_Obj* targetName; /* Name of the event(s) to delete */ sl@0: char* targetNameStr; sl@0: sl@0: if ( event->proc != TesteventProc ) { sl@0: return 0; sl@0: } sl@0: targetName = (Tcl_Obj*) clientData; sl@0: targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL ); sl@0: ev = (TestEvent*) event; sl@0: evNameStr = Tcl_GetStringFromObj( ev->tag, NULL ); sl@0: if ( strcmp( evNameStr, targetNameStr ) == 0 ) { sl@0: Tcl_DecrRefCount( ev->tag ); sl@0: Tcl_DecrRefCount( ev->command ); sl@0: return 1; sl@0: } else { sl@0: return 0; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestexithandlerCmd -- sl@0: * sl@0: * This procedure implements the "testexithandler" command. It is sl@0: * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestexithandlerCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int value; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " create|delete value\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, sl@0: (ClientData) value); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, sl@0: (ClientData) value); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": must be create or delete", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static void sl@0: ExitProcOdd(clientData) sl@0: ClientData clientData; /* Integer value to print. */ sl@0: { sl@0: char buf[16 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(buf, "odd %d\n", (int) clientData); sl@0: write(1, buf, strlen(buf)); sl@0: } sl@0: sl@0: static void sl@0: ExitProcEven(clientData) sl@0: ClientData clientData; /* Integer value to print. */ sl@0: { sl@0: char buf[16 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(buf, "even %d\n", (int) clientData); sl@0: write(1, buf, strlen(buf)); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestexprlongCmd -- sl@0: * sl@0: * This procedure verifies that Tcl_ExprLong does not modify the sl@0: * interpreter result if there is no error. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestexprlongCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: long exprResult; sl@0: char buf[4 + TCL_INTEGER_SPACE]; sl@0: int result; sl@0: sl@0: Tcl_SetResult(interp, "This is a result", TCL_STATIC); sl@0: result = Tcl_ExprLong(interp, "4+1", &exprResult); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sprintf(buf, ": %ld", exprResult); sl@0: Tcl_AppendResult(interp, buf, NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestexprstringCmd -- sl@0: * sl@0: * This procedure tests the basic operation of Tcl_ExprString. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestexprstringCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " expression\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return Tcl_ExprString(interp, argv[1]); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestfilelinkCmd -- sl@0: * sl@0: * This procedure implements the "testfilelink" command. It is used sl@0: * to test the effects of creating and manipulating filesystem links sl@0: * in Tcl. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * May create a link on disk. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestfilelinkCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: Tcl_Obj *contents; sl@0: sl@0: if (objc < 2 || objc > 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "source ?target?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 3) { sl@0: /* Create link from source to target */ sl@0: contents = Tcl_FSLink(objv[1], objv[2], sl@0: TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK); sl@0: if (contents == NULL) { sl@0: Tcl_AppendResult(interp, "could not create link from \"", sl@0: Tcl_GetString(objv[1]), "\" to \"", sl@0: Tcl_GetString(objv[2]), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: /* Read link */ sl@0: contents = Tcl_FSLink(objv[1], NULL, 0); sl@0: if (contents == NULL) { sl@0: Tcl_AppendResult(interp, "could not read link \"", sl@0: Tcl_GetString(objv[1]), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_SetObjResult(interp, contents); sl@0: if (objc == 2) { sl@0: /* sl@0: * If we are creating a link, this will actually just sl@0: * be objv[3], and we don't own it sl@0: */ sl@0: Tcl_DecrRefCount(contents); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestgetassocdataCmd -- sl@0: * sl@0: * This procedure implements the "testgetassocdata" command. It is sl@0: * used to test Tcl_GetAssocData. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestgetassocdataCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: char *res; sl@0: sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " data_key\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); sl@0: if (res != NULL) { sl@0: Tcl_AppendResult(interp, res, NULL); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestgetplatformCmd -- sl@0: * sl@0: * This procedure implements the "testgetplatform" command. It is sl@0: * used to retrievel the value of the tclPlatform global variable. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestgetplatformCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: static CONST char *platformStrings[] = { "unix", "mac", "windows" }; sl@0: TclPlatformType *platform; sl@0: sl@0: #ifdef __WIN32__ sl@0: platform = TclWinGetPlatform(); sl@0: #else sl@0: platform = &tclPlatform; sl@0: #endif sl@0: sl@0: if (argc != 1) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_AppendResult(interp, platformStrings[*platform], NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestinterpdeleteCmd -- sl@0: * sl@0: * This procedure tests the code in tclInterp.c that deals with sl@0: * interpreter deletion. It deletes a user-specified interpreter sl@0: * from the hierarchy, and subsequent code checks integrity. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Deletes one or more interpreters. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestinterpdeleteCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_Interp *slaveToDelete; sl@0: sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " path\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveToDelete = Tcl_GetSlave(interp, argv[1]); sl@0: if (slaveToDelete == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DeleteInterp(slaveToDelete); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestlinkCmd -- sl@0: * sl@0: * This procedure implements the "testlink" command. It is used sl@0: * to test Tcl_LinkVar and related library procedures. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes various variable links, plus returns sl@0: * values of the linked variables. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestlinkCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: static int intVar = 43; sl@0: static int boolVar = 4; sl@0: static double realVar = 1.23; sl@0: static Tcl_WideInt wideVar = Tcl_LongAsWide(79); sl@0: static char *stringVar = NULL; sl@0: static int created = 0; sl@0: char buffer[2*TCL_DOUBLE_SPACE]; sl@0: int writable, flag; sl@0: Tcl_Obj *tmp; sl@0: sl@0: if (argc < 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option ?arg arg arg arg arg?\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "create") == 0) { sl@0: if (argc != 7) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " ", argv[1], sl@0: " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (created) { sl@0: Tcl_UnlinkVar(interp, "int"); sl@0: Tcl_UnlinkVar(interp, "real"); sl@0: Tcl_UnlinkVar(interp, "bool"); sl@0: Tcl_UnlinkVar(interp, "string"); sl@0: Tcl_UnlinkVar(interp, "wide"); sl@0: } sl@0: created = 1; sl@0: if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; sl@0: if (Tcl_LinkVar(interp, "int", (char *) &intVar, sl@0: TCL_LINK_INT | flag) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; sl@0: if (Tcl_LinkVar(interp, "real", (char *) &realVar, sl@0: TCL_LINK_DOUBLE | flag) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; sl@0: if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, sl@0: TCL_LINK_BOOLEAN | flag) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; sl@0: if (Tcl_LinkVar(interp, "string", (char *) &stringVar, sl@0: TCL_LINK_STRING | flag) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; sl@0: if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, sl@0: TCL_LINK_WIDE_INT | flag) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: Tcl_UnlinkVar(interp, "int"); sl@0: Tcl_UnlinkVar(interp, "real"); sl@0: Tcl_UnlinkVar(interp, "bool"); sl@0: Tcl_UnlinkVar(interp, "string"); sl@0: Tcl_UnlinkVar(interp, "wide"); sl@0: created = 0; sl@0: } else if (strcmp(argv[1], "get") == 0) { sl@0: TclFormatInt(buffer, intVar); sl@0: Tcl_AppendElement(interp, buffer); sl@0: Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); sl@0: Tcl_AppendElement(interp, buffer); sl@0: TclFormatInt(buffer, boolVar); sl@0: Tcl_AppendElement(interp, buffer); sl@0: Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); sl@0: /* sl@0: * Wide ints only have an object-based interface. sl@0: */ sl@0: tmp = Tcl_NewWideIntObj(wideVar); sl@0: Tcl_AppendElement(interp, Tcl_GetString(tmp)); sl@0: Tcl_DecrRefCount(tmp); sl@0: } else if (strcmp(argv[1], "set") == 0) { sl@0: if (argc != 7) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " ", argv[1], sl@0: " intValue realValue boolValue stringValue wideValue\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (argv[2][0] != 0) { sl@0: if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: if (argv[3][0] != 0) { sl@0: if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: if (argv[4][0] != 0) { sl@0: if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: if (argv[5][0] != 0) { sl@0: if (stringVar != NULL) { sl@0: ckfree(stringVar); sl@0: } sl@0: if (strcmp(argv[5], "-") == 0) { sl@0: stringVar = NULL; sl@0: } else { sl@0: stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); sl@0: strcpy(stringVar, argv[5]); sl@0: } sl@0: } sl@0: if (argv[6][0] != 0) { sl@0: tmp = Tcl_NewStringObj(argv[6], -1); sl@0: if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { sl@0: Tcl_DecrRefCount(tmp); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DecrRefCount(tmp); sl@0: } sl@0: } else if (strcmp(argv[1], "update") == 0) { sl@0: if (argc != 7) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " ", argv[1], sl@0: "intValue realValue boolValue stringValue wideValue\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (argv[2][0] != 0) { sl@0: if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_UpdateLinkedVar(interp, "int"); sl@0: } sl@0: if (argv[3][0] != 0) { sl@0: if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_UpdateLinkedVar(interp, "real"); sl@0: } sl@0: if (argv[4][0] != 0) { sl@0: if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_UpdateLinkedVar(interp, "bool"); sl@0: } sl@0: if (argv[5][0] != 0) { sl@0: if (stringVar != NULL) { sl@0: ckfree(stringVar); sl@0: } sl@0: if (strcmp(argv[5], "-") == 0) { sl@0: stringVar = NULL; sl@0: } else { sl@0: stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); sl@0: strcpy(stringVar, argv[5]); sl@0: } sl@0: Tcl_UpdateLinkedVar(interp, "string"); sl@0: } sl@0: if (argv[6][0] != 0) { sl@0: tmp = Tcl_NewStringObj(argv[6], -1); sl@0: if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { sl@0: Tcl_DecrRefCount(tmp); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DecrRefCount(tmp); sl@0: Tcl_UpdateLinkedVar(interp, "wide"); sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], sl@0: "\": should be create, delete, get, set, or update", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestlocaleCmd -- sl@0: * sl@0: * This procedure implements the "testlocale" command. It is used sl@0: * to test the effects of setting different locales in Tcl. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Modifies the current C locale. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestlocaleCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: int index; sl@0: char *locale; sl@0: sl@0: static CONST char *optionStrings[] = { sl@0: "ctype", "numeric", "time", "collate", "monetary", sl@0: "all", NULL sl@0: }; sl@0: static int lcTypes[] = { sl@0: LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, sl@0: LC_ALL sl@0: }; sl@0: sl@0: /* sl@0: * LC_CTYPE, etc. correspond to the indices for the strings. sl@0: */ sl@0: sl@0: if (objc < 2 || objc > 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 3) { sl@0: locale = Tcl_GetString(objv[2]); sl@0: } else { sl@0: locale = NULL; sl@0: } sl@0: locale = setlocale(lcTypes[index], locale); sl@0: if (locale) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestMathFunc -- sl@0: * sl@0: * This is a user-defined math procedure to test out math procedures sl@0: * with no arguments. sl@0: * sl@0: * Results: sl@0: * A normal Tcl completion code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestMathFunc(clientData, interp, args, resultPtr) sl@0: ClientData clientData; /* Integer value to return. */ sl@0: Tcl_Interp *interp; /* Not used. */ sl@0: Tcl_Value *args; /* Not used. */ sl@0: Tcl_Value *resultPtr; /* Where to store result. */ sl@0: { sl@0: resultPtr->type = TCL_INT; sl@0: resultPtr->intValue = (int) clientData; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestMathFunc2 -- sl@0: * sl@0: * This is a user-defined math procedure to test out math procedures sl@0: * that do have arguments, in this case 2. sl@0: * sl@0: * Results: sl@0: * A normal Tcl completion code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestMathFunc2(clientData, interp, args, resultPtr) sl@0: ClientData clientData; /* Integer value to return. */ sl@0: Tcl_Interp *interp; /* Used to report errors. */ sl@0: Tcl_Value *args; /* Points to an array of two sl@0: * Tcl_Value structs for the sl@0: * two arguments. */ sl@0: Tcl_Value *resultPtr; /* Where to store the result. */ sl@0: { sl@0: int result = TCL_OK; sl@0: sl@0: /* sl@0: * Return the maximum of the two arguments with the correct type. sl@0: */ sl@0: sl@0: if (args[0].type == TCL_INT) { sl@0: int i0 = args[0].intValue; sl@0: sl@0: if (args[1].type == TCL_INT) { sl@0: int i1 = args[1].intValue; sl@0: sl@0: resultPtr->type = TCL_INT; sl@0: resultPtr->intValue = ((i0 > i1)? i0 : i1); sl@0: } else if (args[1].type == TCL_DOUBLE) { sl@0: double d0 = i0; sl@0: double d1 = args[1].doubleValue; sl@0: sl@0: resultPtr->type = TCL_DOUBLE; sl@0: resultPtr->doubleValue = ((d0 > d1)? d0 : d1); sl@0: } else if (args[1].type == TCL_WIDE_INT) { sl@0: Tcl_WideInt w0 = Tcl_LongAsWide(i0); sl@0: Tcl_WideInt w1 = args[1].wideValue; sl@0: sl@0: resultPtr->type = TCL_WIDE_INT; sl@0: resultPtr->wideValue = ((w0 > w1)? w0 : w1); sl@0: } else { sl@0: Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: } else if (args[0].type == TCL_DOUBLE) { sl@0: double d0 = args[0].doubleValue; sl@0: sl@0: if (args[1].type == TCL_INT) { sl@0: double d1 = args[1].intValue; sl@0: sl@0: resultPtr->type = TCL_DOUBLE; sl@0: resultPtr->doubleValue = ((d0 > d1)? d0 : d1); sl@0: } else if (args[1].type == TCL_DOUBLE) { sl@0: double d1 = args[1].doubleValue; sl@0: sl@0: resultPtr->type = TCL_DOUBLE; sl@0: resultPtr->doubleValue = ((d0 > d1)? d0 : d1); sl@0: } else if (args[1].type == TCL_WIDE_INT) { sl@0: double d1 = Tcl_WideAsDouble(args[1].wideValue); sl@0: sl@0: resultPtr->type = TCL_DOUBLE; sl@0: resultPtr->doubleValue = ((d0 > d1)? d0 : d1); sl@0: } else { sl@0: Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: } else if (args[0].type == TCL_WIDE_INT) { sl@0: Tcl_WideInt w0 = args[0].wideValue; sl@0: sl@0: if (args[1].type == TCL_INT) { sl@0: Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); sl@0: sl@0: resultPtr->type = TCL_WIDE_INT; sl@0: resultPtr->wideValue = ((w0 > w1)? w0 : w1); sl@0: } else if (args[1].type == TCL_DOUBLE) { sl@0: double d0 = Tcl_WideAsDouble(w0); sl@0: double d1 = args[1].doubleValue; sl@0: sl@0: resultPtr->type = TCL_DOUBLE; sl@0: resultPtr->doubleValue = ((d0 > d1)? d0 : d1); sl@0: } else if (args[1].type == TCL_WIDE_INT) { sl@0: Tcl_WideInt w1 = args[1].wideValue; sl@0: sl@0: resultPtr->type = TCL_WIDE_INT; sl@0: resultPtr->wideValue = ((w0 > w1)? w0 : w1); sl@0: } else { sl@0: Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CleanupTestSetassocdataTests -- sl@0: * sl@0: * This function is called when an interpreter is deleted to clean sl@0: * up any data left over from running the testsetassocdata command. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Releases storage. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: /* ARGSUSED */ sl@0: static void sl@0: CleanupTestSetassocdataTests(clientData, interp) sl@0: ClientData clientData; /* Data to be released. */ sl@0: Tcl_Interp *interp; /* Interpreter being deleted. */ sl@0: { sl@0: ckfree((char *) clientData); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestparserObjCmd -- sl@0: * sl@0: * This procedure implements the "testparser" command. It is sl@0: * used for testing the new Tcl script parser in Tcl 8.1. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestparserObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: char *script; sl@0: int length, dummy; sl@0: Tcl_Parse parse; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "script length"); sl@0: return TCL_ERROR; sl@0: } sl@0: script = Tcl_GetStringFromObj(objv[1], &dummy); sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &length)) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (length == 0) { sl@0: length = dummy; sl@0: } sl@0: if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) { sl@0: Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); sl@0: Tcl_AddErrorInfo(interp, parse.term); sl@0: Tcl_AddErrorInfo(interp, "\")"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * The parse completed successfully. Just print out the contents sl@0: * of the parse structure into the interpreter's result. sl@0: */ sl@0: sl@0: PrintParse(interp, &parse); sl@0: Tcl_FreeParse(&parse); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestexprparserObjCmd -- sl@0: * sl@0: * This procedure implements the "testexprparser" command. It is sl@0: * used for testing the new Tcl expression parser in Tcl 8.1. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestexprparserObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: char *script; sl@0: int length, dummy; sl@0: Tcl_Parse parse; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "expr length"); sl@0: return TCL_ERROR; sl@0: } sl@0: script = Tcl_GetStringFromObj(objv[1], &dummy); sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &length)) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (length == 0) { sl@0: length = dummy; sl@0: } sl@0: if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) { sl@0: Tcl_AddErrorInfo(interp, "\n (remainder of expr: \""); sl@0: Tcl_AddErrorInfo(interp, parse.term); sl@0: Tcl_AddErrorInfo(interp, "\")"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * The parse completed successfully. Just print out the contents sl@0: * of the parse structure into the interpreter's result. sl@0: */ sl@0: sl@0: PrintParse(interp, &parse); sl@0: Tcl_FreeParse(&parse); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * PrintParse -- sl@0: * sl@0: * This procedure prints out the contents of a Tcl_Parse structure sl@0: * in the result of an interpreter. sl@0: * sl@0: * Results: sl@0: * Interp's result is set to a prettily formatted version of the sl@0: * contents of parsePtr. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: PrintParse(interp, parsePtr) sl@0: Tcl_Interp *interp; /* Interpreter whose result is to be set to sl@0: * the contents of a parse structure. */ sl@0: Tcl_Parse *parsePtr; /* Parse structure to print out. */ sl@0: { sl@0: Tcl_Obj *objPtr; sl@0: char *typeString; sl@0: Tcl_Token *tokenPtr; sl@0: int i; sl@0: sl@0: objPtr = Tcl_GetObjResult(interp); sl@0: if (parsePtr->commentSize > 0) { sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj(parsePtr->commentStart, sl@0: parsePtr->commentSize)); sl@0: } else { sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj("-", 1)); sl@0: } sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewIntObj(parsePtr->numWords)); sl@0: for (i = 0; i < parsePtr->numTokens; i++) { sl@0: tokenPtr = &parsePtr->tokenPtr[i]; sl@0: switch (tokenPtr->type) { sl@0: case TCL_TOKEN_WORD: sl@0: typeString = "word"; sl@0: break; sl@0: case TCL_TOKEN_SIMPLE_WORD: sl@0: typeString = "simple"; sl@0: break; sl@0: case TCL_TOKEN_TEXT: sl@0: typeString = "text"; sl@0: break; sl@0: case TCL_TOKEN_BS: sl@0: typeString = "backslash"; sl@0: break; sl@0: case TCL_TOKEN_COMMAND: sl@0: typeString = "command"; sl@0: break; sl@0: case TCL_TOKEN_VARIABLE: sl@0: typeString = "variable"; sl@0: break; sl@0: case TCL_TOKEN_SUB_EXPR: sl@0: typeString = "subexpr"; sl@0: break; sl@0: case TCL_TOKEN_OPERATOR: sl@0: typeString = "operator"; sl@0: break; sl@0: default: sl@0: typeString = "??"; sl@0: break; sl@0: } sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj(typeString, -1)); sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewIntObj(tokenPtr->numComponents)); sl@0: } sl@0: Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, sl@0: Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, sl@0: -1)); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestparsevarObjCmd -- sl@0: * sl@0: * This procedure implements the "testparsevar" command. It is sl@0: * used for testing Tcl_ParseVar. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestparsevarObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: CONST char *value; sl@0: CONST char *name, *termPtr; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName"); sl@0: return TCL_ERROR; sl@0: } sl@0: name = Tcl_GetString(objv[1]); sl@0: value = Tcl_ParseVar(interp, name, &termPtr); sl@0: if (value == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_AppendElement(interp, value); sl@0: Tcl_AppendElement(interp, termPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestparsevarnameObjCmd -- sl@0: * sl@0: * This procedure implements the "testparsevarname" command. It is sl@0: * used for testing the new Tcl script parser in Tcl 8.1. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestparsevarnameObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: char *script; sl@0: int append, length, dummy; sl@0: Tcl_Parse parse; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "script length append"); sl@0: return TCL_ERROR; sl@0: } sl@0: script = Tcl_GetStringFromObj(objv[1], &dummy); sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &length)) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (length == 0) { sl@0: length = dummy; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[3], &append)) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) { sl@0: Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); sl@0: Tcl_AddErrorInfo(interp, parse.term); sl@0: Tcl_AddErrorInfo(interp, "\")"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * The parse completed successfully. Just print out the contents sl@0: * of the parse structure into the interpreter's result. sl@0: */ sl@0: sl@0: parse.commentSize = 0; sl@0: parse.commandStart = script + parse.tokenPtr->size; sl@0: parse.commandSize = 0; sl@0: PrintParse(interp, &parse); sl@0: Tcl_FreeParse(&parse); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestregexpObjCmd -- sl@0: * sl@0: * This procedure implements the "testregexp" command. It is sl@0: * used to give a direct interface for regexp flags. It's identical sl@0: * to Tcl_RegexpObjCmd except for the -xflags option, and the sl@0: * consequences thereof (including the REG_EXPECT kludge). sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestregexpObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int i, ii, indices, stringLength, match, about; sl@0: int hasxflags, cflags, eflags; sl@0: Tcl_RegExp regExpr; sl@0: char *string; sl@0: Tcl_Obj *objPtr; sl@0: Tcl_RegExpInfo info; sl@0: static CONST char *options[] = { sl@0: "-indices", "-nocase", "-about", "-expanded", sl@0: "-line", "-linestop", "-lineanchor", sl@0: "-xflags", sl@0: "--", (char *) NULL sl@0: }; sl@0: enum options { sl@0: REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, sl@0: REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, sl@0: REGEXP_XFLAGS, sl@0: REGEXP_LAST sl@0: }; sl@0: sl@0: indices = 0; sl@0: about = 0; sl@0: cflags = REG_ADVANCED; sl@0: eflags = 0; sl@0: hasxflags = 0; sl@0: sl@0: for (i = 1; i < objc; i++) { sl@0: char *name; sl@0: int index; sl@0: sl@0: name = Tcl_GetString(objv[i]); sl@0: if (name[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum options) index) { sl@0: case REGEXP_INDICES: { sl@0: indices = 1; sl@0: break; sl@0: } sl@0: case REGEXP_NOCASE: { sl@0: cflags |= REG_ICASE; sl@0: break; sl@0: } sl@0: case REGEXP_ABOUT: { sl@0: about = 1; sl@0: break; sl@0: } sl@0: case REGEXP_EXPANDED: { sl@0: cflags |= REG_EXPANDED; sl@0: break; sl@0: } sl@0: case REGEXP_MULTI: { sl@0: cflags |= REG_NEWLINE; sl@0: break; sl@0: } sl@0: case REGEXP_NOCROSS: { sl@0: cflags |= REG_NLSTOP; sl@0: break; sl@0: } sl@0: case REGEXP_NEWL: { sl@0: cflags |= REG_NLANCH; sl@0: break; sl@0: } sl@0: case REGEXP_XFLAGS: { sl@0: hasxflags = 1; sl@0: break; sl@0: } sl@0: case REGEXP_LAST: { sl@0: i++; sl@0: goto endOfForLoop; sl@0: } sl@0: } sl@0: } sl@0: sl@0: endOfForLoop: sl@0: if (objc - i < hasxflags + 2 - about) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: objc -= i; sl@0: objv += i; sl@0: sl@0: if (hasxflags) { sl@0: string = Tcl_GetStringFromObj(objv[0], &stringLength); sl@0: TestregexpXflags(string, stringLength, &cflags, &eflags); sl@0: objc--; sl@0: objv++; sl@0: } sl@0: sl@0: regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); sl@0: if (regExpr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: objPtr = objv[1]; sl@0: sl@0: if (about) { sl@0: if (TclRegAbout(interp, regExpr) < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */, sl@0: objc-2 /* nmatches */, eflags); sl@0: sl@0: if (match < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (match == 0) { sl@0: /* sl@0: * Set the interpreter's object result to an integer object w/ sl@0: * value 0. sl@0: */ sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); sl@0: if (objc > 2 && (cflags®_EXPECT) && indices) { sl@0: char *varName; sl@0: CONST char *value; sl@0: int start, end; sl@0: char resinfo[TCL_INTEGER_SPACE * 2]; sl@0: sl@0: varName = Tcl_GetString(objv[2]); sl@0: TclRegExpRangeUniChar(regExpr, -1, &start, &end); sl@0: sprintf(resinfo, "%d %d", start, end-1); sl@0: value = Tcl_SetVar(interp, varName, resinfo, 0); sl@0: if (value == NULL) { sl@0: Tcl_AppendResult(interp, "couldn't set variable \"", sl@0: varName, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else if (cflags & TCL_REG_CANMATCH) { sl@0: char *varName; sl@0: CONST char *value; sl@0: char resinfo[TCL_INTEGER_SPACE * 2]; sl@0: sl@0: Tcl_RegExpGetInfo(regExpr, &info); sl@0: varName = Tcl_GetString(objv[2]); sl@0: sprintf(resinfo, "%ld", info.extendStart); sl@0: value = Tcl_SetVar(interp, varName, resinfo, 0); sl@0: if (value == NULL) { sl@0: Tcl_AppendResult(interp, "couldn't set variable \"", sl@0: varName, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * If additional variable names have been specified, return sl@0: * index information in those variables. sl@0: */ sl@0: sl@0: objc -= 2; sl@0: objv += 2; sl@0: sl@0: Tcl_RegExpGetInfo(regExpr, &info); sl@0: for (i = 0; i < objc; i++) { sl@0: int start, end; sl@0: Tcl_Obj *newPtr, *varPtr, *valuePtr; sl@0: sl@0: varPtr = objv[i]; sl@0: ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; sl@0: if (indices) { sl@0: Tcl_Obj *objs[2]; sl@0: sl@0: if (ii == -1) { sl@0: TclRegExpRangeUniChar(regExpr, ii, &start, &end); sl@0: } else if (ii > info.nsubs) { sl@0: start = -1; sl@0: end = -1; sl@0: } else { sl@0: start = info.matches[ii].start; sl@0: end = info.matches[ii].end; sl@0: } sl@0: sl@0: /* sl@0: * Adjust index so it refers to the last character in the sl@0: * match instead of the first character after the match. sl@0: */ sl@0: sl@0: if (end >= 0) { sl@0: end--; sl@0: } sl@0: sl@0: objs[0] = Tcl_NewLongObj(start); sl@0: objs[1] = Tcl_NewLongObj(end); sl@0: sl@0: newPtr = Tcl_NewListObj(2, objs); sl@0: } else { sl@0: if (ii == -1) { sl@0: TclRegExpRangeUniChar(regExpr, ii, &start, &end); sl@0: newPtr = Tcl_GetRange(objPtr, start, end); sl@0: } else if (ii > info.nsubs) { sl@0: newPtr = Tcl_NewObj(); sl@0: } else { sl@0: newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, sl@0: info.matches[ii].end - 1); sl@0: } sl@0: } sl@0: Tcl_IncrRefCount(newPtr); sl@0: valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); sl@0: Tcl_DecrRefCount(newPtr); sl@0: if (valuePtr == NULL) { sl@0: Tcl_AppendResult(interp, "couldn't set variable \"", sl@0: Tcl_GetString(varPtr), "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to an integer object w/ value 1. sl@0: */ sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TestregexpXflags -- sl@0: * sl@0: * Parse a string of extended regexp flag letters, for testing. sl@0: * sl@0: * Results: sl@0: * No return value (you're on your own for errors here). sl@0: * sl@0: * Side effects: sl@0: * Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a sl@0: * regexec flags word, as appropriate. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: TestregexpXflags(string, length, cflagsPtr, eflagsPtr) sl@0: char *string; /* The string of flags. */ sl@0: int length; /* The length of the string in bytes. */ sl@0: int *cflagsPtr; /* compile flags word */ sl@0: int *eflagsPtr; /* exec flags word */ sl@0: { sl@0: int i; sl@0: int cflags; sl@0: int eflags; sl@0: sl@0: cflags = *cflagsPtr; sl@0: eflags = *eflagsPtr; sl@0: for (i = 0; i < length; i++) { sl@0: switch (string[i]) { sl@0: case 'a': { sl@0: cflags |= REG_ADVF; sl@0: break; sl@0: } sl@0: case 'b': { sl@0: cflags &= ~REG_ADVANCED; sl@0: break; sl@0: } sl@0: case 'c': { sl@0: cflags |= TCL_REG_CANMATCH; sl@0: break; sl@0: } sl@0: case 'e': { sl@0: cflags &= ~REG_ADVANCED; sl@0: cflags |= REG_EXTENDED; sl@0: break; sl@0: } sl@0: case 'q': { sl@0: cflags &= ~REG_ADVANCED; sl@0: cflags |= REG_QUOTE; sl@0: break; sl@0: } sl@0: case 'o': { /* o for opaque */ sl@0: cflags |= REG_NOSUB; sl@0: break; sl@0: } sl@0: case 's': { /* s for start */ sl@0: cflags |= REG_BOSONLY; sl@0: break; sl@0: } sl@0: case '+': { sl@0: cflags |= REG_FAKE; sl@0: break; sl@0: } sl@0: case ',': { sl@0: cflags |= REG_PROGRESS; sl@0: break; sl@0: } sl@0: case '.': { sl@0: cflags |= REG_DUMP; sl@0: break; sl@0: } sl@0: case ':': { sl@0: eflags |= REG_MTRACE; sl@0: break; sl@0: } sl@0: case ';': { sl@0: eflags |= REG_FTRACE; sl@0: break; sl@0: } sl@0: case '^': { sl@0: eflags |= REG_NOTBOL; sl@0: break; sl@0: } sl@0: case '$': { sl@0: eflags |= REG_NOTEOL; sl@0: break; sl@0: } sl@0: case 't': { sl@0: cflags |= REG_EXPECT; sl@0: break; sl@0: } sl@0: case '%': { sl@0: eflags |= REG_SMALL; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: *cflagsPtr = cflags; sl@0: *eflagsPtr = eflags; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsetassocdataCmd -- sl@0: * sl@0: * This procedure implements the "testsetassocdata" command. It is used sl@0: * to test Tcl_SetAssocData. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Modifies or creates an association between a key and associated sl@0: * data for this interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestsetassocdataCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: char *buf; sl@0: char *oldData; sl@0: Tcl_InterpDeleteProc *procPtr; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " data_key data_item\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: buf = ckalloc((unsigned) strlen(argv[2]) + 1); sl@0: strcpy(buf, argv[2]); sl@0: sl@0: /* sl@0: * If we previously associated a malloced value with the variable, sl@0: * free it before associating a new value. sl@0: */ sl@0: sl@0: oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); sl@0: if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { sl@0: ckfree(oldData); sl@0: } sl@0: sl@0: Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, sl@0: (ClientData) buf); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsetplatformCmd -- sl@0: * sl@0: * This procedure implements the "testsetplatform" command. It is sl@0: * used to change the tclPlatform global variable so all file sl@0: * name conversions can be tested on a single platform. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Sets the tclPlatform global variable. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestsetplatformCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: size_t length; sl@0: TclPlatformType *platform; sl@0: sl@0: #ifdef __WIN32__ sl@0: platform = TclWinGetPlatform(); sl@0: #else sl@0: platform = &tclPlatform; sl@0: #endif sl@0: sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], sl@0: " platform\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: length = strlen(argv[1]); sl@0: if (strncmp(argv[1], "unix", length) == 0) { sl@0: *platform = TCL_PLATFORM_UNIX; sl@0: } else if (strncmp(argv[1], "mac", length) == 0) { sl@0: *platform = TCL_PLATFORM_MAC; sl@0: } else if (strncmp(argv[1], "windows", length) == 0) { sl@0: *platform = TCL_PLATFORM_WINDOWS; sl@0: } else { sl@0: Tcl_AppendResult(interp, "unsupported platform: should be one of ", sl@0: "unix, mac, or windows", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TeststaticpkgCmd -- sl@0: * sl@0: * This procedure implements the "teststaticpkg" command. sl@0: * It is used to test the procedure Tcl_StaticPackage. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * When the packge given by argv[1] is loaded into an interpeter, sl@0: * variable "x" in that interpreter is set to "loaded". sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TeststaticpkgCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int safe, loaded; sl@0: sl@0: if (argc != 4) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", sl@0: argv[0], " pkgName safe loaded\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, sl@0: (safe) ? StaticInitProc : NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: StaticInitProc(interp) sl@0: Tcl_Interp *interp; /* Interpreter in which package sl@0: * is supposedly being loaded. */ sl@0: { sl@0: Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TesttranslatefilenameCmd -- sl@0: * sl@0: * This procedure implements the "testtranslatefilename" command. sl@0: * It is used to test the Tcl_TranslateFileName command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TesttranslatefilenameCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_DString buffer; sl@0: CONST char *result; sl@0: sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", sl@0: argv[0], " path\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: result = Tcl_TranslateFileName(interp, argv[1], &buffer); sl@0: if (result == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendResult(interp, result, NULL); sl@0: Tcl_DStringFree(&buffer); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestupvarCmd -- sl@0: * sl@0: * This procedure implements the "testupvar2" command. It is used sl@0: * to test Tcl_UpVar and Tcl_UpVar2. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates or modifies an "upvar" reference. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestupvarCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int flags = 0; sl@0: sl@0: if ((argc != 5) && (argc != 6)) { sl@0: Tcl_AppendResult(interp, "wrong # arguments: should be \"", sl@0: argv[0], " level name ?name2? dest global\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (argc == 5) { sl@0: if (strcmp(argv[4], "global") == 0) { sl@0: flags = TCL_GLOBAL_ONLY; sl@0: } else if (strcmp(argv[4], "namespace") == 0) { sl@0: flags = TCL_NAMESPACE_ONLY; sl@0: } sl@0: return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); sl@0: } else { sl@0: if (strcmp(argv[5], "global") == 0) { sl@0: flags = TCL_GLOBAL_ONLY; sl@0: } else if (strcmp(argv[5], "namespace") == 0) { sl@0: flags = TCL_NAMESPACE_ONLY; sl@0: } sl@0: return Tcl_UpVar2(interp, argv[1], argv[2], sl@0: (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], sl@0: flags); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestseterrorcodeCmd -- sl@0: * sl@0: * This procedure implements the "testseterrorcodeCmd". sl@0: * This tests up to five elements passed to the sl@0: * Tcl_SetErrorCode command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. Always returns TCL_ERROR so that sl@0: * the error code can be tested. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestseterrorcodeCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: if (argc > 6) { sl@0: Tcl_SetResult(interp, "too many args", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], sl@0: argv[5], NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsetobjerrorcodeCmd -- sl@0: * sl@0: * This procedure implements the "testsetobjerrorcodeCmd". sl@0: * This tests the Tcl_SetObjErrorCode function. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. Always returns TCL_ERROR so that sl@0: * the error code can be tested. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestsetobjerrorcodeCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: Tcl_Obj *listObjPtr; sl@0: sl@0: if (objc > 1) { sl@0: listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1); sl@0: } else { sl@0: listObjPtr = Tcl_NewObj(); sl@0: } sl@0: Tcl_IncrRefCount(listObjPtr); sl@0: Tcl_SetObjErrorCode(interp, listObjPtr); sl@0: Tcl_DecrRefCount(listObjPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestfeventCmd -- sl@0: * sl@0: * This procedure implements the "testfevent" command. It is sl@0: * used for testing the "fileevent" command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates and deletes interpreters. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestfeventCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: static Tcl_Interp *interp2 = NULL; sl@0: int code; sl@0: Tcl_Channel chan; sl@0: sl@0: if (argc < 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " option ?arg arg ...?", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[1], "cmd") == 0) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " cmd script", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (interp2 != (Tcl_Interp *) NULL) { sl@0: code = Tcl_GlobalEval(interp2, argv[2]); sl@0: Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); sl@0: return code; sl@0: } else { sl@0: Tcl_AppendResult(interp, sl@0: "called \"testfevent code\" before \"testfevent create\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else if (strcmp(argv[1], "create") == 0) { sl@0: if (interp2 != NULL) { sl@0: Tcl_DeleteInterp(interp2); sl@0: } sl@0: interp2 = Tcl_CreateInterp(); sl@0: return Tcl_Init(interp2); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: if (interp2 != NULL) { sl@0: Tcl_DeleteInterp(interp2); sl@0: } sl@0: interp2 = NULL; sl@0: } else if (strcmp(argv[1], "share") == 0) { sl@0: if (interp2 != NULL) { sl@0: chan = Tcl_GetChannel(interp, argv[2], NULL); sl@0: if (chan == (Tcl_Channel) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_RegisterChannel(interp2, chan); sl@0: } sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestpanicCmd -- sl@0: * sl@0: * Calls the panic routine. sl@0: * sl@0: * Results: sl@0: * Always returns TCL_OK. sl@0: * sl@0: * Side effects: sl@0: * May exit application. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestpanicCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: CONST char *argString; sl@0: sl@0: /* sl@0: * Put the arguments into a var args structure sl@0: * Append all of the arguments together separated by spaces sl@0: */ sl@0: sl@0: argString = Tcl_Merge(argc-1, argv+1); sl@0: panic(argString); sl@0: ckfree((char *)argString); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: TestfileCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST argv[]; /* The argument objects. */ sl@0: { sl@0: int force, i, j, result; sl@0: Tcl_Obj *error = NULL; sl@0: char *subcmd; sl@0: sl@0: if (argc < 3) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: force = 0; sl@0: i = 2; sl@0: if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) { sl@0: force = 1; sl@0: i = 3; sl@0: } sl@0: sl@0: if (argc - i > 2) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (j = i; j < argc; j++) { sl@0: if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: subcmd = Tcl_GetString(argv[1]); sl@0: sl@0: if (strcmp(subcmd, "mv") == 0) { sl@0: result = TclpObjRenameFile(argv[i], argv[i + 1]); sl@0: } else if (strcmp(subcmd, "cp") == 0) { sl@0: result = TclpObjCopyFile(argv[i], argv[i + 1]); sl@0: } else if (strcmp(subcmd, "rm") == 0) { sl@0: result = TclpObjDeleteFile(argv[i]); sl@0: } else if (strcmp(subcmd, "mkdir") == 0) { sl@0: result = TclpObjCreateDirectory(argv[i]); sl@0: } else if (strcmp(subcmd, "cpdir") == 0) { sl@0: result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error); sl@0: } else if (strcmp(subcmd, "rmdir") == 0) { sl@0: result = TclpObjRemoveDirectory(argv[i], force, &error); sl@0: } else { sl@0: result = TCL_ERROR; sl@0: goto end; sl@0: } sl@0: sl@0: if (result != TCL_OK) { sl@0: if (error != NULL) { sl@0: if (Tcl_GetString(error)[0] != '\0') { sl@0: Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL); sl@0: } sl@0: Tcl_DecrRefCount(error); sl@0: } sl@0: Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); sl@0: } sl@0: sl@0: end: sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestgetvarfullnameCmd -- sl@0: * sl@0: * Implements the "testgetvarfullname" cmd that is used when testing sl@0: * the Tcl_GetVariableFullName procedure. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestgetvarfullnameCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: char *name, *arg; sl@0: int flags = 0; sl@0: Tcl_Namespace *namespacePtr; sl@0: Tcl_CallFrame frame; sl@0: Tcl_Var variable; sl@0: int result; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "name scope"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetString(objv[1]); sl@0: sl@0: arg = Tcl_GetString(objv[2]); sl@0: if (strcmp(arg, "global") == 0) { sl@0: flags = TCL_GLOBAL_ONLY; sl@0: } else if (strcmp(arg, "namespace") == 0) { sl@0: flags = TCL_NAMESPACE_ONLY; sl@0: } sl@0: sl@0: /* sl@0: * This command, like any other created with Tcl_Create[Obj]Command, sl@0: * runs in the global namespace. As a "namespace-aware" command that sl@0: * needs to run in a particular namespace, it must activate that sl@0: * namespace itself. sl@0: */ sl@0: sl@0: if (flags == TCL_NAMESPACE_ONLY) { sl@0: namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", sl@0: (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); sl@0: if (namespacePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: result = Tcl_PushCallFrame(interp, &frame, namespacePtr, sl@0: /*isProcCallFrame*/ 0); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, sl@0: (flags | TCL_LEAVE_ERR_MSG)); sl@0: sl@0: if (flags == TCL_NAMESPACE_ONLY) { sl@0: Tcl_PopCallFrame(interp); sl@0: } sl@0: if (variable == (Tcl_Var) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetTimesCmd -- sl@0: * sl@0: * This procedure implements the "gettimes" command. It is sl@0: * used for computing the time needed for various basic operations sl@0: * such as reading variables, allocating memory, sprintf, converting sl@0: * variables, etc. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Allocates and frees memory, sets a variable "a" in the interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetTimesCmd(unused, interp, argc, argv) sl@0: ClientData unused; /* Unused. */ sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: int argc; /* The number of arguments. */ sl@0: CONST char **argv; /* The argument strings. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int i, n; sl@0: double timePer; sl@0: Tcl_Time start, stop; sl@0: Tcl_Obj *objPtr; sl@0: Tcl_Obj **objv; sl@0: CONST char *s; sl@0: char newString[TCL_INTEGER_SPACE]; sl@0: sl@0: /* alloc & free 100000 times */ sl@0: fprintf(stderr, "alloc & free 100000 6 word items\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); sl@0: ckfree((char *) objPtr); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); sl@0: sl@0: /* alloc 5000 times */ sl@0: fprintf(stderr, "alloc 5000 6 word items\n"); sl@0: objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 5000; i++) { sl@0: objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); sl@0: sl@0: /* free 5000 times */ sl@0: fprintf(stderr, "free 5000 6 word items\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 5000; i++) { sl@0: ckfree((char *) objv[i]); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per free\n", timePer/5000); sl@0: sl@0: /* Tcl_NewObj 5000 times */ sl@0: fprintf(stderr, "Tcl_NewObj 5000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 5000; i++) { sl@0: objv[i] = Tcl_NewObj(); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000); sl@0: sl@0: /* Tcl_DecrRefCount 5000 times */ sl@0: fprintf(stderr, "Tcl_DecrRefCount 5000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 5000; i++) { sl@0: objPtr = objv[i]; sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); sl@0: ckfree((char *) objv); sl@0: sl@0: /* TclGetString 100000 times */ sl@0: fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); sl@0: objPtr = Tcl_NewStringObj("12345", -1); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: (void) TclGetString(objPtr); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", sl@0: timePer/100000); sl@0: sl@0: /* Tcl_GetIntFromObj 100000 times */ sl@0: fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n", sl@0: timePer/100000); sl@0: Tcl_DecrRefCount(objPtr); sl@0: sl@0: /* Tcl_GetInt 100000 times */ sl@0: fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", sl@0: timePer/100000); sl@0: sl@0: /* sprintf 100000 times */ sl@0: fprintf(stderr, "sprintf of 12345 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: sprintf(newString, "%d", 12345); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per sprintf of 12345\n", sl@0: timePer/100000); sl@0: sl@0: /* hashtable lookup 100000 times */ sl@0: fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes"); sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", sl@0: timePer/100000); sl@0: sl@0: /* Tcl_SetVar 100000 times */ sl@0: fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); sl@0: if (s == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n", sl@0: timePer/100000); sl@0: sl@0: /* Tcl_GetVar 100000 times */ sl@0: fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); sl@0: Tcl_GetTime(&start); sl@0: for (i = 0; i < 100000; i++) { sl@0: s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); sl@0: if (s == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); sl@0: fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n", sl@0: timePer/100000); sl@0: sl@0: Tcl_ResetResult(interp); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NoopCmd -- sl@0: * sl@0: * This procedure is just used to time the overhead involved in sl@0: * parsing and invoking a command. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NoopCmd(unused, interp, argc, argv) sl@0: ClientData unused; /* Unused. */ sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: int argc; /* The number of arguments. */ sl@0: CONST char **argv; /* The argument strings. */ sl@0: { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NoopObjCmd -- sl@0: * sl@0: * This object-based procedure is just used to time the overhead sl@0: * involved in parsing and invoking a command. sl@0: * sl@0: * Results: sl@0: * Returns the TCL_OK result code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NoopObjCmd(unused, interp, objc, objv) sl@0: ClientData unused; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsetCmd -- sl@0: * sl@0: * Implements the "testset{err,noerr}" cmds that are used when testing sl@0: * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Variables may be set. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestsetCmd(data, interp, argc, argv) sl@0: ClientData data; /* Additional flags for Get/SetVar2. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: int flags = (int) data; sl@0: CONST char *value; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_SetResult(interp, "before get", TCL_STATIC); sl@0: value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags); sl@0: if (value == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendElement(interp, value); sl@0: return TCL_OK; sl@0: } else if (argc == 3) { sl@0: Tcl_SetResult(interp, "before set", TCL_STATIC); sl@0: value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags); sl@0: if (value == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendElement(interp, value); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " varName ?newValue?\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsaveresultCmd -- sl@0: * sl@0: * Implements the "testsaveresult" cmd that is used when testing sl@0: * the Tcl_SaveResult, Tcl_RestoreResult, and sl@0: * Tcl_DiscardResult interfaces. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestsaveresultCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: int discard, result, index; sl@0: Tcl_SavedResult state; sl@0: Tcl_Obj *objPtr; sl@0: static CONST char *optionStrings[] = { sl@0: "append", "dynamic", "free", "object", "small", NULL sl@0: }; sl@0: enum options { sl@0: RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL sl@0: }; sl@0: sl@0: /* sl@0: * Parse arguments sl@0: */ sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: objPtr = NULL; /* Lint. */ sl@0: switch ((enum options) index) { sl@0: case RESULT_SMALL: sl@0: Tcl_SetResult(interp, "small result", TCL_VOLATILE); sl@0: break; sl@0: case RESULT_APPEND: sl@0: Tcl_AppendResult(interp, "append result", NULL); sl@0: break; sl@0: case RESULT_FREE: { sl@0: char *buf = ckalloc(200); sl@0: strcpy(buf, "free result"); sl@0: Tcl_SetResult(interp, buf, TCL_DYNAMIC); sl@0: break; sl@0: } sl@0: case RESULT_DYNAMIC: sl@0: Tcl_SetResult(interp, "dynamic result", TestsaveresultFree); sl@0: break; sl@0: case RESULT_OBJECT: sl@0: objPtr = Tcl_NewStringObj("object result", -1); sl@0: Tcl_SetObjResult(interp, objPtr); sl@0: break; sl@0: } sl@0: sl@0: freeCount = 0; sl@0: Tcl_SaveResult(interp, &state); sl@0: sl@0: if (((enum options) index) == RESULT_OBJECT) { sl@0: result = Tcl_EvalObjEx(interp, objv[2], 0); sl@0: } else { sl@0: result = Tcl_Eval(interp, Tcl_GetString(objv[2])); sl@0: } sl@0: sl@0: if (discard) { sl@0: Tcl_DiscardResult(&state); sl@0: } else { sl@0: Tcl_RestoreResult(interp, &state); sl@0: result = TCL_OK; sl@0: } sl@0: sl@0: switch ((enum options) index) { sl@0: case RESULT_DYNAMIC: { sl@0: int present = interp->freeProc == TestsaveresultFree; sl@0: int called = freeCount; sl@0: Tcl_AppendElement(interp, called ? "called" : "notCalled"); sl@0: Tcl_AppendElement(interp, present ? "present" : "missing"); sl@0: break; sl@0: } sl@0: case RESULT_OBJECT: sl@0: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr sl@0: ? "same" : "different"); sl@0: break; sl@0: default: sl@0: break; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsaveresultFree -- sl@0: * sl@0: * Special purpose freeProc used by TestsaveresultCmd. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Increments the freeCount. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: TestsaveresultFree(blockPtr) sl@0: char *blockPtr; sl@0: { sl@0: freeCount++; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TeststatprocCmd -- sl@0: * sl@0: * Implements the "testTclStatProc" cmd that is used to test the sl@0: * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TeststatprocCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: TclStatProc_ *proc; sl@0: int retVal; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " option arg\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[2], "TclpStat") == 0) { sl@0: proc = PretendTclpStat; sl@0: } else if (strcmp(argv[2], "TestStatProc1") == 0) { sl@0: proc = TestStatProc1; sl@0: } else if (strcmp(argv[2], "TestStatProc2") == 0) { sl@0: proc = TestStatProc2; sl@0: } else if (strcmp(argv[2], "TestStatProc3") == 0) { sl@0: proc = TestStatProc3; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be TclpStat, ", sl@0: "TestStatProc1, TestStatProc2, or TestStatProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[1], "insert") == 0) { sl@0: if (proc == PretendTclpStat) { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be ", sl@0: "TestStatProc1, TestStatProc2, or TestStatProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: retVal = TclStatInsertProc(proc); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: retVal = TclStatDeleteProc(proc); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", sl@0: "must be insert or delete", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (retVal == TCL_ERROR) { sl@0: Tcl_AppendResult(interp, "\"", argv[2], "\": ", sl@0: "could not be ", argv[1], "ed", (char *) NULL); sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: static int PretendTclpStat(path, buf) sl@0: CONST char *path; sl@0: struct stat *buf; sl@0: { sl@0: int ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); sl@0: #ifdef TCL_WIDE_INT_IS_LONG sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = TclpObjStat(pathPtr, buf); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: #else /* TCL_WIDE_INT_IS_LONG */ sl@0: Tcl_StatBuf realBuf; sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = TclpObjStat(pathPtr, &realBuf); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: if (ret != -1) { sl@0: # define OUT_OF_RANGE(x) \ sl@0: (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ sl@0: ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) sl@0: #if defined(__GNUC__) && __GNUC__ >= 2 sl@0: /* sl@0: * Workaround gcc warning of "comparison is always false due to limited range of sl@0: * data type" in this macro by checking max type size, and when necessary ANDing sl@0: * with the complement of ULONG_MAX instead of the comparison: sl@0: */ sl@0: # define OUT_OF_URANGE(x) \ sl@0: ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ sl@0: (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) sl@0: #else sl@0: # define OUT_OF_URANGE(x) \ sl@0: (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) sl@0: #endif sl@0: sl@0: /* sl@0: * Perform the result-buffer overflow check manually. sl@0: * sl@0: * Note that ino_t/ino64_t is unsigned... sl@0: */ sl@0: sl@0: if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) sl@0: # ifdef HAVE_ST_BLOCKS sl@0: || OUT_OF_RANGE(realBuf.st_blocks) sl@0: # endif sl@0: ) { sl@0: # ifdef EOVERFLOW sl@0: errno = EOVERFLOW; sl@0: # else sl@0: # ifdef EFBIG sl@0: errno = EFBIG; sl@0: # else sl@0: # error "what error should be returned for a value out of range?" sl@0: # endif sl@0: # endif sl@0: return -1; sl@0: } sl@0: sl@0: # undef OUT_OF_RANGE sl@0: # undef OUT_OF_URANGE sl@0: sl@0: /* sl@0: * Copy across all supported fields, with possible type sl@0: * coercions on those fields that change between the normal sl@0: * and lf64 versions of the stat structure (on Solaris at sl@0: * least.) This is slow when the structure sizes coincide, sl@0: * but that's what you get for mixing interfaces... sl@0: */ sl@0: sl@0: buf->st_mode = realBuf.st_mode; sl@0: buf->st_ino = (ino_t) realBuf.st_ino; sl@0: buf->st_dev = realBuf.st_dev; sl@0: buf->st_rdev = realBuf.st_rdev; sl@0: buf->st_nlink = realBuf.st_nlink; sl@0: buf->st_uid = realBuf.st_uid; sl@0: buf->st_gid = realBuf.st_gid; sl@0: buf->st_size = (off_t) realBuf.st_size; sl@0: buf->st_atime = realBuf.st_atime; sl@0: buf->st_mtime = realBuf.st_mtime; sl@0: buf->st_ctime = realBuf.st_ctime; sl@0: # ifdef HAVE_ST_BLOCKS sl@0: buf->st_blksize = realBuf.st_blksize; sl@0: buf->st_blocks = (blkcnt_t) realBuf.st_blocks; sl@0: # endif sl@0: } sl@0: return ret; sl@0: #endif /* TCL_WIDE_INT_IS_LONG */ sl@0: } sl@0: sl@0: /* Be careful in the compares in these tests, since the Macintosh puts a sl@0: * leading : in the beginning of non-absolute paths before passing them sl@0: * into the file command procedures. sl@0: */ sl@0: sl@0: static int sl@0: TestStatProc1(path, buf) sl@0: CONST char *path; sl@0: struct stat *buf; sl@0: { sl@0: memset(buf, 0, sizeof(struct stat)); sl@0: buf->st_size = 1234; sl@0: return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: sl@0: static int sl@0: TestStatProc2(path, buf) sl@0: CONST char *path; sl@0: struct stat *buf; sl@0: { sl@0: memset(buf, 0, sizeof(struct stat)); sl@0: buf->st_size = 2345; sl@0: return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: sl@0: static int sl@0: TestStatProc3(path, buf) sl@0: CONST char *path; sl@0: struct stat *buf; sl@0: { sl@0: memset(buf, 0, sizeof(struct stat)); sl@0: buf->st_size = 3456; sl@0: return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestmainthreadCmd -- sl@0: * sl@0: * Implements the "testmainthread" cmd that is used to test the sl@0: * 'Tcl_GetCurrentThread' API. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestmainthreadCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: if (argc == 1) { sl@0: Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); sl@0: Tcl_SetObjResult(interp, idObj); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_SetResult(interp, "wrong # args", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * MainLoop -- sl@0: * sl@0: * A main loop set by TestsetmainloopCmd below. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Event handlers could do anything. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: MainLoop(void) sl@0: { sl@0: while (!exitMainLoop) { sl@0: Tcl_DoOneEvent(0); sl@0: } sl@0: fprintf(stdout,"Exit MainLoop\n"); sl@0: fflush(stdout); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestsetmainloopCmd -- sl@0: * sl@0: * Implements the "testsetmainloop" cmd that is used to test the sl@0: * 'Tcl_SetMainLoop' API. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestsetmainloopCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: exitMainLoop = 0; sl@0: Tcl_SetMainLoop(MainLoop); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestexitmainloopCmd -- sl@0: * sl@0: * Implements the "testexitmainloop" cmd that is used to test the sl@0: * 'Tcl_SetMainLoop' API. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestexitmainloopCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: exitMainLoop = 1; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestaccessprocCmd -- sl@0: * sl@0: * Implements the "testTclAccessProc" cmd that is used to test the sl@0: * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestaccessprocCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: TclAccessProc_ *proc; sl@0: int retVal; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " option arg\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[2], "TclpAccess") == 0) { sl@0: proc = PretendTclpAccess; sl@0: } else if (strcmp(argv[2], "TestAccessProc1") == 0) { sl@0: proc = TestAccessProc1; sl@0: } else if (strcmp(argv[2], "TestAccessProc2") == 0) { sl@0: proc = TestAccessProc2; sl@0: } else if (strcmp(argv[2], "TestAccessProc3") == 0) { sl@0: proc = TestAccessProc3; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be TclpAccess, ", sl@0: "TestAccessProc1, TestAccessProc2, or TestAccessProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[1], "insert") == 0) { sl@0: if (proc == PretendTclpAccess) { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be ", sl@0: "TestAccessProc1, TestAccessProc2, or TestAccessProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: retVal = TclAccessInsertProc(proc); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: retVal = TclAccessDeleteProc(proc); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", sl@0: "must be insert or delete", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (retVal == TCL_ERROR) { sl@0: Tcl_AppendResult(interp, "\"", argv[2], "\": ", sl@0: "could not be ", argv[1], "ed", (char *) NULL); sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: static int PretendTclpAccess(path, mode) sl@0: CONST char *path; sl@0: int mode; sl@0: { sl@0: int ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = TclpObjAccess(pathPtr, mode); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: } sl@0: sl@0: static int sl@0: TestAccessProc1(path, mode) sl@0: CONST char *path; sl@0: int mode; sl@0: { sl@0: return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: sl@0: static int sl@0: TestAccessProc2(path, mode) sl@0: CONST char *path; sl@0: int mode; sl@0: { sl@0: return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: sl@0: static int sl@0: TestAccessProc3(path, mode) sl@0: CONST char *path; sl@0: int mode; sl@0: { sl@0: return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestopenfilechannelprocCmd -- sl@0: * sl@0: * Implements the "testTclOpenFileChannelProc" cmd that is used to test the sl@0: * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestopenfilechannelprocCmd (dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: TclOpenFileChannelProc_ *proc; sl@0: int retVal; sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " option arg\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { sl@0: proc = PretendTclpOpenFileChannel; sl@0: } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { sl@0: proc = TestOpenFileChannelProc1; sl@0: } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { sl@0: proc = TestOpenFileChannelProc2; sl@0: } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { sl@0: proc = TestOpenFileChannelProc3; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be TclpOpenFileChannel, ", sl@0: "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", sl@0: "TestOpenFileChannelProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[1], "insert") == 0) { sl@0: if (proc == PretendTclpOpenFileChannel) { sl@0: Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", sl@0: "must be ", sl@0: "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", sl@0: "TestOpenFileChannelProc3", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: retVal = TclOpenFileChannelInsertProc(proc); sl@0: } else if (strcmp(argv[1], "delete") == 0) { sl@0: retVal = TclOpenFileChannelDeleteProc(proc); sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", sl@0: "must be insert or delete", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (retVal == TCL_ERROR) { sl@0: Tcl_AppendResult(interp, "\"", argv[2], "\": ", sl@0: "could not be ", argv[1], "ed", (char *) NULL); sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: static Tcl_Channel sl@0: PretendTclpOpenFileChannel(interp, fileName, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: CONST char *fileName; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: Tcl_Channel ret; sl@0: int mode, seekFlag; sl@0: Tcl_Obj *pathPtr; sl@0: mode = TclGetOpenMode(interp, modeString, &seekFlag); sl@0: if (mode == -1) { sl@0: return NULL; sl@0: } sl@0: pathPtr = Tcl_NewStringObj(fileName, -1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: if (ret != NULL) { sl@0: if (seekFlag) { sl@0: if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, sl@0: "could not seek to end of file while opening \"", sl@0: fileName, "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: } sl@0: Tcl_Close(NULL, ret); sl@0: return NULL; sl@0: } sl@0: } sl@0: } sl@0: return ret; sl@0: } sl@0: sl@0: static Tcl_Channel sl@0: TestOpenFileChannelProc1(interp, fileName, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: CONST char *fileName; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: CONST char *expectname="testOpenFileChannel1%.fil"; sl@0: Tcl_DString ds; sl@0: sl@0: Tcl_DStringInit(&ds); sl@0: Tcl_JoinPath(1, &expectname, &ds); sl@0: sl@0: if (!strcmp(Tcl_DStringValue(&ds), fileName)) { sl@0: Tcl_DStringFree(&ds); sl@0: return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", sl@0: modeString, permissions)); sl@0: } else { sl@0: Tcl_DStringFree(&ds); sl@0: return (NULL); sl@0: } sl@0: } sl@0: sl@0: sl@0: static Tcl_Channel sl@0: TestOpenFileChannelProc2(interp, fileName, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: CONST char *fileName; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: CONST char *expectname="testOpenFileChannel2%.fil"; sl@0: Tcl_DString ds; sl@0: sl@0: Tcl_DStringInit(&ds); sl@0: Tcl_JoinPath(1, &expectname, &ds); sl@0: sl@0: if (!strcmp(Tcl_DStringValue(&ds), fileName)) { sl@0: Tcl_DStringFree(&ds); sl@0: return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", sl@0: modeString, permissions)); sl@0: } else { sl@0: Tcl_DStringFree(&ds); sl@0: return (NULL); sl@0: } sl@0: } sl@0: sl@0: sl@0: static Tcl_Channel sl@0: TestOpenFileChannelProc3(interp, fileName, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: CONST char *fileName; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: CONST char *expectname="testOpenFileChannel3%.fil"; sl@0: Tcl_DString ds; sl@0: sl@0: Tcl_DStringInit(&ds); sl@0: Tcl_JoinPath(1, &expectname, &ds); sl@0: sl@0: if (!strcmp(Tcl_DStringValue(&ds), fileName)) { sl@0: Tcl_DStringFree(&ds); sl@0: return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", sl@0: modeString, permissions)); sl@0: } else { sl@0: Tcl_DStringFree(&ds); sl@0: return (NULL); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestChannelCmd -- sl@0: * sl@0: * Implements the Tcl "testchannel" debugging command and its sl@0: * subcommands. This is part of the testing environment. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestChannelCmd(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Interpreter for result. */ sl@0: int argc; /* Count of additional args. */ sl@0: CONST char **argv; /* Additional arg strings. */ sl@0: { sl@0: CONST char *cmdName; /* Sub command. */ sl@0: Tcl_HashTable *hTblPtr; /* Hash table of channels. */ sl@0: Tcl_HashSearch hSearch; /* Search variable. */ sl@0: Tcl_HashEntry *hPtr; /* Search variable. */ sl@0: Channel *chanPtr; /* The actual channel. */ sl@0: ChannelState *statePtr; /* state info for channel */ sl@0: Tcl_Channel chan; /* The opaque type. */ sl@0: size_t len; /* Length of subcommand string. */ sl@0: int IOQueued; /* How much IO is queued inside channel? */ sl@0: ChannelBuffer *bufPtr; /* For iterating over queued IO. */ sl@0: char buf[TCL_INTEGER_SPACE];/* For sprintf. */ sl@0: int mode; /* rw mode of the channel */ sl@0: sl@0: if (argc < 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " subcommand ?additional args..?\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: cmdName = argv[1]; sl@0: len = strlen(cmdName); sl@0: sl@0: chanPtr = (Channel *) NULL; sl@0: sl@0: if (argc > 2) { sl@0: chan = Tcl_GetChannel(interp, argv[2], &mode); sl@0: if (chan == (Tcl_Channel) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: chanPtr = (Channel *) chan; sl@0: statePtr = chanPtr->state; sl@0: chanPtr = statePtr->topChanPtr; sl@0: chan = (Tcl_Channel) chanPtr; sl@0: } else { sl@0: /* lint */ sl@0: statePtr = NULL; sl@0: chan = NULL; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " cut channelName\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_CutChannel(chan); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'c') && sl@0: (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " clearchannelhandlers channelName\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_ClearChannelHandlers(chan); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " info channelName\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendElement(interp, argv[2]); sl@0: Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr)); sl@0: if (statePtr->flags & TCL_READABLE) { sl@0: Tcl_AppendElement(interp, "read"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: if (statePtr->flags & TCL_WRITABLE) { sl@0: Tcl_AppendElement(interp, "write"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: if (statePtr->flags & CHANNEL_NONBLOCKING) { sl@0: Tcl_AppendElement(interp, "nonblocking"); sl@0: } else { sl@0: Tcl_AppendElement(interp, "blocking"); sl@0: } sl@0: if (statePtr->flags & CHANNEL_LINEBUFFERED) { sl@0: Tcl_AppendElement(interp, "line"); sl@0: } else if (statePtr->flags & CHANNEL_UNBUFFERED) { sl@0: Tcl_AppendElement(interp, "none"); sl@0: } else { sl@0: Tcl_AppendElement(interp, "full"); sl@0: } sl@0: if (statePtr->flags & BG_FLUSH_SCHEDULED) { sl@0: Tcl_AppendElement(interp, "async_flush"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: if (statePtr->flags & CHANNEL_EOF) { sl@0: Tcl_AppendElement(interp, "eof"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: if (statePtr->flags & CHANNEL_BLOCKED) { sl@0: Tcl_AppendElement(interp, "blocked"); sl@0: } else { sl@0: Tcl_AppendElement(interp, "unblocked"); sl@0: } sl@0: if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) { sl@0: Tcl_AppendElement(interp, "auto"); sl@0: if (statePtr->flags & INPUT_SAW_CR) { sl@0: Tcl_AppendElement(interp, "saw_cr"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) { sl@0: Tcl_AppendElement(interp, "lf"); sl@0: Tcl_AppendElement(interp, ""); sl@0: } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { sl@0: Tcl_AppendElement(interp, "cr"); sl@0: Tcl_AppendElement(interp, ""); sl@0: } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) { sl@0: Tcl_AppendElement(interp, "crlf"); sl@0: if (statePtr->flags & INPUT_SAW_CR) { sl@0: Tcl_AppendElement(interp, "queued_cr"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: } sl@0: if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) { sl@0: Tcl_AppendElement(interp, "auto"); sl@0: } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) { sl@0: Tcl_AppendElement(interp, "lf"); sl@0: } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) { sl@0: Tcl_AppendElement(interp, "cr"); sl@0: } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) { sl@0: Tcl_AppendElement(interp, "crlf"); sl@0: } sl@0: for (IOQueued = 0, bufPtr = statePtr->inQueueHead; sl@0: bufPtr != (ChannelBuffer *) NULL; sl@0: bufPtr = bufPtr->nextPtr) { sl@0: IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; sl@0: } sl@0: TclFormatInt(buf, IOQueued); sl@0: Tcl_AppendElement(interp, buf); sl@0: sl@0: IOQueued = 0; sl@0: if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { sl@0: IOQueued = statePtr->curOutPtr->nextAdded - sl@0: statePtr->curOutPtr->nextRemoved; sl@0: } sl@0: for (bufPtr = statePtr->outQueueHead; sl@0: bufPtr != (ChannelBuffer *) NULL; sl@0: bufPtr = bufPtr->nextPtr) { sl@0: IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); sl@0: } sl@0: TclFormatInt(buf, IOQueued); sl@0: Tcl_AppendElement(interp, buf); sl@0: sl@0: TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr)); sl@0: Tcl_AppendElement(interp, buf); sl@0: sl@0: TclFormatInt(buf, statePtr->refCount); sl@0: Tcl_AppendElement(interp, buf); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'i') && sl@0: (strncmp(cmdName, "inputbuffered", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (IOQueued = 0, bufPtr = statePtr->inQueueHead; sl@0: bufPtr != (ChannelBuffer *) NULL; sl@0: bufPtr = bufPtr->nextPtr) { sl@0: IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; sl@0: } sl@0: TclFormatInt(buf, IOQueued); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: TclFormatInt(buf, Tcl_IsChannelShared(chan)); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: TclFormatInt(buf, Tcl_IsStandardChannel(chan)); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (statePtr->flags & TCL_READABLE) { sl@0: Tcl_AppendElement(interp, "read"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: if (statePtr->flags & TCL_WRITABLE) { sl@0: Tcl_AppendElement(interp, "write"); sl@0: } else { sl@0: Tcl_AppendElement(interp, ""); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { sl@0: hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); sl@0: if (hTblPtr == (Tcl_HashTable *) NULL) { sl@0: return TCL_OK; sl@0: } sl@0: for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); sl@0: hPtr != (Tcl_HashEntry *) NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'o') && sl@0: (strncmp(cmdName, "outputbuffered", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: IOQueued = 0; sl@0: if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { sl@0: IOQueued = statePtr->curOutPtr->nextAdded - sl@0: statePtr->curOutPtr->nextRemoved; sl@0: } sl@0: for (bufPtr = statePtr->outQueueHead; sl@0: bufPtr != (ChannelBuffer *) NULL; sl@0: bufPtr = bufPtr->nextPtr) { sl@0: IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); sl@0: } sl@0: TclFormatInt(buf, IOQueued); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'q') && sl@0: (strncmp(cmdName, "queuedcr", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_AppendResult(interp, sl@0: (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", sl@0: (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { sl@0: hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); sl@0: if (hTblPtr == (Tcl_HashTable *) NULL) { sl@0: return TCL_OK; sl@0: } sl@0: for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); sl@0: hPtr != (Tcl_HashEntry *) NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: chanPtr = (Channel *) Tcl_GetHashValue(hPtr); sl@0: statePtr = chanPtr->state; sl@0: if (statePtr->flags & TCL_READABLE) { sl@0: Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: TclFormatInt(buf, statePtr->refCount); sl@0: Tcl_AppendResult(interp, buf, (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_SpliceChannel(chan); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "channel name required", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), sl@0: (char *) NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { sl@0: hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); sl@0: if (hTblPtr == (Tcl_HashTable *) NULL) { sl@0: return TCL_OK; sl@0: } sl@0: for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); sl@0: hPtr != (Tcl_HashEntry *) NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: chanPtr = (Channel *) Tcl_GetHashValue(hPtr); sl@0: statePtr = chanPtr->state; sl@0: if (statePtr->flags & TCL_WRITABLE) { sl@0: Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) { sl@0: /* sl@0: * Syntax: transform channel -command command sl@0: */ sl@0: sl@0: if (argc != 5) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " transform channelId -command cmd\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[3], "-command") != 0) { sl@0: Tcl_AppendResult(interp, "bad argument \"", argv[3], sl@0: "\": should be \"-command\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TclChannelTransform(interp, chan, sl@0: Tcl_NewStringObj(argv[4], -1)); sl@0: } sl@0: sl@0: if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) { sl@0: /* sl@0: * Syntax: unstack channel sl@0: */ sl@0: sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " unstack channel\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return Tcl_UnstackChannel(interp, chan); sl@0: } sl@0: sl@0: Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", sl@0: "cut, clearchannelhandlers, info, isshared, mode, open, " sl@0: "readable, splice, writable, transform, unstack", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestChannelEventCmd -- sl@0: * sl@0: * This procedure implements the "testchannelevent" command. It is sl@0: * used to test the Tcl channel event mechanism. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates, deletes and returns channel event handlers. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static int sl@0: TestChannelEventCmd(dummy, interp, argc, argv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Tcl_Obj *resultListPtr; sl@0: Channel *chanPtr; sl@0: ChannelState *statePtr; /* state info for channel */ sl@0: EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; sl@0: CONST char *cmd; sl@0: int index, i, mask, len; sl@0: sl@0: if ((argc < 3) || (argc > 5)) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); sl@0: if (chanPtr == (Channel *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: statePtr = chanPtr->state; sl@0: sl@0: cmd = argv[2]; sl@0: len = strlen(cmd); sl@0: if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { sl@0: if (argc != 5) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName add eventSpec script\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (strcmp(argv[3], "readable") == 0) { sl@0: mask = TCL_READABLE; sl@0: } else if (strcmp(argv[3], "writable") == 0) { sl@0: mask = TCL_WRITABLE; sl@0: } else if (strcmp(argv[3], "none") == 0) { sl@0: mask = 0; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad event name \"", argv[3], sl@0: "\": must be readable, writable, or none", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: esPtr = (EventScriptRecord *) ckalloc((unsigned) sl@0: sizeof(EventScriptRecord)); sl@0: esPtr->nextPtr = statePtr->scriptRecordPtr; sl@0: statePtr->scriptRecordPtr = esPtr; sl@0: sl@0: esPtr->chanPtr = chanPtr; sl@0: esPtr->interp = interp; sl@0: esPtr->mask = mask; sl@0: esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); sl@0: Tcl_IncrRefCount(esPtr->scriptPtr); sl@0: sl@0: Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, sl@0: TclChannelEventScriptInvoker, (ClientData) esPtr); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { sl@0: if (argc != 4) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName delete index\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index < 0) { sl@0: Tcl_AppendResult(interp, "bad event index: ", argv[3], sl@0: ": must be nonnegative", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 0, esPtr = statePtr->scriptRecordPtr; sl@0: (i < index) && (esPtr != (EventScriptRecord *) NULL); sl@0: i++, esPtr = esPtr->nextPtr) { sl@0: /* Empty loop body. */ sl@0: } sl@0: if (esPtr == (EventScriptRecord *) NULL) { sl@0: Tcl_AppendResult(interp, "bad event index ", argv[3], sl@0: ": out of range", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (esPtr == statePtr->scriptRecordPtr) { sl@0: statePtr->scriptRecordPtr = esPtr->nextPtr; sl@0: } else { sl@0: for (prevEsPtr = statePtr->scriptRecordPtr; sl@0: (prevEsPtr != (EventScriptRecord *) NULL) && sl@0: (prevEsPtr->nextPtr != esPtr); sl@0: prevEsPtr = prevEsPtr->nextPtr) { sl@0: /* Empty loop body. */ sl@0: } sl@0: if (prevEsPtr == (EventScriptRecord *) NULL) { sl@0: panic("TestChannelEventCmd: damaged event script list"); sl@0: } sl@0: prevEsPtr->nextPtr = esPtr->nextPtr; sl@0: } sl@0: Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, sl@0: TclChannelEventScriptInvoker, (ClientData) esPtr); sl@0: Tcl_DecrRefCount(esPtr->scriptPtr); sl@0: ckfree((char *) esPtr); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName list\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: resultListPtr = Tcl_GetObjResult(interp); sl@0: for (esPtr = statePtr->scriptRecordPtr; sl@0: esPtr != (EventScriptRecord *) NULL; sl@0: esPtr = esPtr->nextPtr) { sl@0: if (esPtr->mask) { sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( sl@0: (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); sl@0: } else { sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, sl@0: Tcl_NewStringObj("none", -1)); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, resultListPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName removeall\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: for (esPtr = statePtr->scriptRecordPtr; sl@0: esPtr != (EventScriptRecord *) NULL; sl@0: esPtr = nextEsPtr) { sl@0: nextEsPtr = esPtr->nextPtr; sl@0: Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, sl@0: TclChannelEventScriptInvoker, (ClientData) esPtr); sl@0: Tcl_DecrRefCount(esPtr->scriptPtr); sl@0: ckfree((char *) esPtr); sl@0: } sl@0: statePtr->scriptRecordPtr = (EventScriptRecord *) NULL; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { sl@0: if (argc != 5) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], sl@0: " channelName delete index event\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index < 0) { sl@0: Tcl_AppendResult(interp, "bad event index: ", argv[3], sl@0: ": must be nonnegative", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 0, esPtr = statePtr->scriptRecordPtr; sl@0: (i < index) && (esPtr != (EventScriptRecord *) NULL); sl@0: i++, esPtr = esPtr->nextPtr) { sl@0: /* Empty loop body. */ sl@0: } sl@0: if (esPtr == (EventScriptRecord *) NULL) { sl@0: Tcl_AppendResult(interp, "bad event index ", argv[3], sl@0: ": out of range", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(argv[4], "readable") == 0) { sl@0: mask = TCL_READABLE; sl@0: } else if (strcmp(argv[4], "writable") == 0) { sl@0: mask = TCL_WRITABLE; sl@0: } else if (strcmp(argv[4], "none") == 0) { sl@0: mask = 0; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad event name \"", argv[4], sl@0: "\": must be readable, writable, or none", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: esPtr->mask = mask; sl@0: Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, sl@0: TclChannelEventScriptInvoker, (ClientData) esPtr); sl@0: return TCL_OK; sl@0: } sl@0: Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", sl@0: "add, delete, list, set, or removeall", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestWrongNumArgsObjCmd -- sl@0: * sl@0: * Test the Tcl_WrongNumArgs function. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Sets interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestWrongNumArgsObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int i, length; sl@0: char *msg; sl@0: sl@0: if (objc < 3) { sl@0: /* sl@0: * Don't use Tcl_WrongNumArgs here, as that is the function sl@0: * we want to test! sl@0: */ sl@0: Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: msg = Tcl_GetStringFromObj(objv[2], &length); sl@0: if (length == 0) { sl@0: msg = NULL; sl@0: } sl@0: sl@0: if (i > objc - 3) { sl@0: /* sl@0: * Asked for more arguments than were given. sl@0: */ sl@0: Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestGetIndexFromObjStructObjCmd -- sl@0: * sl@0: * Test the Tcl_GetIndexFromObjStruct function. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Sets interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *ary[] = { sl@0: "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL sl@0: }; sl@0: int idx,target; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), sl@0: "dummy", 0, &idx) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (idx != target) { sl@0: char buffer[64]; sl@0: sprintf(buffer, "%d", idx); sl@0: Tcl_AppendResult(interp, "index value comparison failed: got ", sl@0: buffer, NULL); sl@0: sprintf(buffer, "%d", target); sl@0: Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_WrongNumArgs(interp, 3, objv, NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TestFilesystemObjCmd -- sl@0: * sl@0: * This procedure implements the "testfilesystem" command. It is sl@0: * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used sl@0: * to test that the pluggable filesystem works. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Inserts or removes a filesystem from Tcl's stack. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TestFilesystemObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; sl@0: Tcl_Interp *interp; sl@0: int objc; sl@0: Tcl_Obj *CONST objv[]; sl@0: { sl@0: int res, boolVal; sl@0: char *msg; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "boolean"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (boolVal) { sl@0: res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); sl@0: msg = (res == TCL_OK) ? "registered" : "failed"; sl@0: } else { sl@0: res = Tcl_FSUnregister(&testReportingFilesystem); sl@0: msg = (res == TCL_OK) ? "unregistered" : "failed"; sl@0: } sl@0: Tcl_SetResult(interp, msg, TCL_VOLATILE); sl@0: return res; sl@0: } sl@0: sl@0: static int sl@0: TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) sl@0: { sl@0: static Tcl_Obj* lastPathPtr = NULL; sl@0: sl@0: if (pathPtr == lastPathPtr) { sl@0: /* Reject all files second time around */ sl@0: return -1; sl@0: } else { sl@0: Tcl_Obj * newPathPtr; sl@0: /* Try to claim all files first time around */ sl@0: sl@0: newPathPtr = Tcl_DuplicateObj(pathPtr); sl@0: lastPathPtr = newPathPtr; sl@0: Tcl_IncrRefCount(newPathPtr); sl@0: if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { sl@0: /* Nothing claimed it. Therefore we don't either */ sl@0: Tcl_DecrRefCount(newPathPtr); sl@0: lastPathPtr = NULL; sl@0: return -1; sl@0: } else { sl@0: lastPathPtr = NULL; sl@0: *clientDataPtr = (ClientData) newPathPtr; sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Simple helper function to extract the native vfs representation of a sl@0: * path object, or NULL if no such representation exists. sl@0: */ sl@0: static Tcl_Obj* sl@0: TestReportGetNativePath(Tcl_Obj* pathObjPtr) { sl@0: return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem); sl@0: } sl@0: sl@0: static void sl@0: TestReportFreeInternalRep(ClientData clientData) { sl@0: Tcl_Obj *nativeRep = (Tcl_Obj*)clientData; sl@0: if (nativeRep != NULL) { sl@0: /* Free the path */ sl@0: Tcl_DecrRefCount(nativeRep); sl@0: } sl@0: } sl@0: sl@0: static ClientData sl@0: TestReportDupInternalRep(ClientData clientData) { sl@0: Tcl_Obj *original = (Tcl_Obj*)clientData; sl@0: Tcl_IncrRefCount(original); sl@0: return clientData; sl@0: } sl@0: sl@0: static void sl@0: TestReport(cmd, path, arg2) sl@0: CONST char* cmd; sl@0: Tcl_Obj* path; sl@0: Tcl_Obj* arg2; sl@0: { sl@0: Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem); sl@0: if (interp == NULL) { sl@0: /* This is bad, but not much we can do about it */ sl@0: } else { sl@0: /* sl@0: * No idea why I decided to program this up using the sl@0: * old string-based API, but there you go. We should sl@0: * convert it to objects. sl@0: */ sl@0: Tcl_SavedResult savedResult; sl@0: Tcl_DString ds; sl@0: Tcl_DStringInit(&ds); sl@0: Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1); sl@0: Tcl_DStringStartSublist(&ds); sl@0: Tcl_DStringAppendElement(&ds, cmd); sl@0: if (path != NULL) { sl@0: Tcl_DStringAppendElement(&ds, Tcl_GetString(path)); sl@0: } sl@0: if (arg2 != NULL) { sl@0: Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); sl@0: } sl@0: Tcl_DStringEndSublist(&ds); sl@0: Tcl_SaveResult(interp, &savedResult); sl@0: Tcl_Eval(interp, Tcl_DStringValue(&ds)); sl@0: Tcl_DStringFree(&ds); sl@0: Tcl_RestoreResult(interp, &savedResult); sl@0: } sl@0: } sl@0: sl@0: static int sl@0: TestReportStat(path, buf) sl@0: Tcl_Obj *path; /* Path of file to stat (in current CP). */ sl@0: Tcl_StatBuf *buf; /* Filled with results of stat call. */ sl@0: { sl@0: TestReport("stat",path, NULL); sl@0: return Tcl_FSStat(TestReportGetNativePath(path),buf); sl@0: } sl@0: static int sl@0: TestReportLstat(path, buf) sl@0: Tcl_Obj *path; /* Path of file to stat (in current CP). */ sl@0: Tcl_StatBuf *buf; /* Filled with results of stat call. */ sl@0: { sl@0: TestReport("lstat",path, NULL); sl@0: return Tcl_FSLstat(TestReportGetNativePath(path),buf); sl@0: } sl@0: static int sl@0: TestReportAccess(path, mode) sl@0: Tcl_Obj *path; /* Path of file to access (in current CP). */ sl@0: int mode; /* Permission setting. */ sl@0: { sl@0: TestReport("access",path,NULL); sl@0: return Tcl_FSAccess(TestReportGetNativePath(path),mode); sl@0: } sl@0: static Tcl_Channel sl@0: TestReportOpenFileChannel(interp, fileName, mode, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: Tcl_Obj *fileName; /* Name of file to open. */ sl@0: int mode; /* POSIX open mode. */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: TestReport("open",fileName, NULL); sl@0: return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName), sl@0: mode, permissions); sl@0: } sl@0: sl@0: static int sl@0: TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) sl@0: Tcl_Interp *interp; /* Interpreter to receive results. */ sl@0: Tcl_Obj *resultPtr; /* Object to lappend results. */ sl@0: Tcl_Obj *dirPtr; /* Contains path to directory to search. */ sl@0: CONST char *pattern; /* Pattern to match against. */ sl@0: Tcl_GlobTypeData *types; /* Object containing list of acceptable types. sl@0: * May be NULL. */ sl@0: { sl@0: if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { sl@0: TestReport("matchmounts",dirPtr, NULL); sl@0: return TCL_OK; sl@0: } else { sl@0: TestReport("matchindirectory",dirPtr, NULL); sl@0: return Tcl_FSMatchInDirectory(interp, resultPtr, sl@0: TestReportGetNativePath(dirPtr), pattern, sl@0: types); sl@0: } sl@0: } sl@0: static int sl@0: TestReportChdir(dirName) sl@0: Tcl_Obj *dirName; sl@0: { sl@0: TestReport("chdir",dirName,NULL); sl@0: return Tcl_FSChdir(TestReportGetNativePath(dirName)); sl@0: } sl@0: static int sl@0: TestReportLoadFile(interp, fileName, sl@0: handlePtr, unloadProcPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: Tcl_Obj *fileName; /* Name of the file containing the desired sl@0: * code. */ sl@0: Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded sl@0: * file which will be passed back to sl@0: * (*unloadProcPtr)() to unload the file. */ sl@0: Tcl_FSUnloadFileProc **unloadProcPtr; sl@0: /* Filled with address of Tcl_FSUnloadFileProc sl@0: * function which should be used for sl@0: * this file. */ sl@0: { sl@0: TestReport("loadfile",fileName,NULL); sl@0: return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL, sl@0: NULL, NULL, handlePtr, unloadProcPtr); sl@0: } sl@0: static Tcl_Obj * sl@0: TestReportLink(path, to, linkType) sl@0: Tcl_Obj *path; /* Path of file to readlink or link */ sl@0: Tcl_Obj *to; /* Path of file to link to, or NULL */ sl@0: int linkType; sl@0: { sl@0: TestReport("link",path,to); sl@0: return Tcl_FSLink(TestReportGetNativePath(path), to, linkType); sl@0: } sl@0: static int sl@0: TestReportRenameFile(src, dst) sl@0: Tcl_Obj *src; /* Pathname of file or dir to be renamed sl@0: * (UTF-8). */ sl@0: Tcl_Obj *dst; /* New pathname of file or directory sl@0: * (UTF-8). */ sl@0: { sl@0: TestReport("renamefile",src,dst); sl@0: return Tcl_FSRenameFile(TestReportGetNativePath(src), sl@0: TestReportGetNativePath(dst)); sl@0: } sl@0: static int sl@0: TestReportCopyFile(src, dst) sl@0: Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */ sl@0: Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ sl@0: { sl@0: TestReport("copyfile",src,dst); sl@0: return Tcl_FSCopyFile(TestReportGetNativePath(src), sl@0: TestReportGetNativePath(dst)); sl@0: } sl@0: static int sl@0: TestReportDeleteFile(path) sl@0: Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ sl@0: { sl@0: TestReport("deletefile",path,NULL); sl@0: return Tcl_FSDeleteFile(TestReportGetNativePath(path)); sl@0: } sl@0: static int sl@0: TestReportCreateDirectory(path) sl@0: Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ sl@0: { sl@0: TestReport("createdirectory",path,NULL); sl@0: return Tcl_FSCreateDirectory(TestReportGetNativePath(path)); sl@0: } sl@0: static int sl@0: TestReportCopyDirectory(src, dst, errorPtr) sl@0: Tcl_Obj *src; /* Pathname of directory to be copied sl@0: * (UTF-8). */ sl@0: Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ sl@0: Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name sl@0: * of file causing error. */ sl@0: { sl@0: TestReport("copydirectory",src,dst); sl@0: return Tcl_FSCopyDirectory(TestReportGetNativePath(src), sl@0: TestReportGetNativePath(dst), errorPtr); sl@0: } sl@0: static int sl@0: TestReportRemoveDirectory(path, recursive, errorPtr) sl@0: Tcl_Obj *path; /* Pathname of directory to be removed sl@0: * (UTF-8). */ sl@0: int recursive; /* If non-zero, removes directories that sl@0: * are nonempty. Otherwise, will only remove sl@0: * empty directories. */ sl@0: Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name sl@0: * of file causing error. */ sl@0: { sl@0: TestReport("removedirectory",path,NULL); sl@0: return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, sl@0: errorPtr); sl@0: } sl@0: static CONST char** sl@0: TestReportFileAttrStrings(fileName, objPtrRef) sl@0: Tcl_Obj* fileName; sl@0: Tcl_Obj** objPtrRef; sl@0: { sl@0: TestReport("fileattributestrings",fileName,NULL); sl@0: return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef); sl@0: } sl@0: static int sl@0: TestReportFileAttrsGet(interp, index, fileName, objPtrRef) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *fileName; /* filename we are operating on. */ sl@0: Tcl_Obj **objPtrRef; /* for output. */ sl@0: { sl@0: TestReport("fileattributesget",fileName,NULL); sl@0: return Tcl_FSFileAttrsGet(interp, index, sl@0: TestReportGetNativePath(fileName), objPtrRef); sl@0: } sl@0: static int sl@0: TestReportFileAttrsSet(interp, index, fileName, objPtr) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *fileName; /* filename we are operating on. */ sl@0: Tcl_Obj *objPtr; /* for input. */ sl@0: { sl@0: TestReport("fileattributesset",fileName,objPtr); sl@0: return Tcl_FSFileAttrsSet(interp, index, sl@0: TestReportGetNativePath(fileName), objPtr); sl@0: } sl@0: static int sl@0: TestReportUtime (fileName, tval) sl@0: Tcl_Obj* fileName; sl@0: struct utimbuf *tval; sl@0: { sl@0: TestReport("utime",fileName,NULL); sl@0: return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); sl@0: } sl@0: static int sl@0: TestReportNormalizePath(interp, pathPtr, nextCheckpoint) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *pathPtr; sl@0: int nextCheckpoint; sl@0: { sl@0: TestReport("normalizepath",pathPtr,NULL); sl@0: return nextCheckpoint; sl@0: } sl@0: sl@0: static int sl@0: SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { sl@0: CONST char *str = Tcl_GetString(pathPtr); sl@0: if (strncmp(str,"simplefs:/",10)) { sl@0: return -1; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Since TclCopyChannel insists on an interpreter, we use this sl@0: * to simplify our test scripts. Would be better if it could sl@0: * copy without an interp sl@0: */ sl@0: static Tcl_Interp *simpleInterpPtr = NULL; sl@0: /* We use this to ensure we clean up after ourselves */ sl@0: static Tcl_Obj *tempFile = NULL; sl@0: sl@0: /* sl@0: * This is a very 'hacky' filesystem which is used just to sl@0: * test two important features of the vfs code: (1) that sl@0: * you can load a shared library from a vfs, (2) that when sl@0: * copying files from one fs to another, the 'mtime' is sl@0: * preserved. sl@0: * sl@0: * It treats any file in 'simplefs:/' as a file, and sl@0: * artificially creates a real file on the fly which it uses sl@0: * to extract information from. The real file it uses is sl@0: * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'), sl@0: * and that file is assumed to exist in the native pwd, and is sl@0: * copied over to the native temporary directory where it is sl@0: * accessed. sl@0: * sl@0: * Please do not consider this filesystem a model of how sl@0: * things are to be done. It is quite the opposite! But, it sl@0: * does allow us to test two important features. sl@0: * sl@0: * Finally: this fs can only be used from one interpreter. sl@0: */ sl@0: static int sl@0: TestSimpleFilesystemObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; sl@0: Tcl_Interp *interp; sl@0: int objc; sl@0: Tcl_Obj *CONST objv[]; sl@0: { sl@0: int res, boolVal; sl@0: char *msg; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "boolean"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (boolVal) { sl@0: res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); sl@0: msg = (res == TCL_OK) ? "registered" : "failed"; sl@0: simpleInterpPtr = interp; sl@0: } else { sl@0: if (tempFile != NULL) { sl@0: Tcl_FSDeleteFile(tempFile); sl@0: Tcl_DecrRefCount(tempFile); sl@0: tempFile = NULL; sl@0: } sl@0: res = Tcl_FSUnregister(&simpleFilesystem); sl@0: msg = (res == TCL_OK) ? "unregistered" : "failed"; sl@0: simpleInterpPtr = NULL; sl@0: } sl@0: Tcl_SetResult(interp, msg, TCL_VOLATILE); sl@0: return res; sl@0: } sl@0: sl@0: /* sl@0: * Treats a file name 'simplefs:/foo' by copying the file 'foo' sl@0: * in the current (native) directory to a temporary native file, sl@0: * and then returns that native file. sl@0: */ sl@0: static Tcl_Obj* sl@0: SimpleCopy(pathPtr) sl@0: Tcl_Obj *pathPtr; /* Name of file to copy. */ sl@0: { sl@0: int res; sl@0: CONST char *str; sl@0: Tcl_Obj *origPtr; sl@0: Tcl_Obj *tempPtr; sl@0: sl@0: tempPtr = TclpTempFileName(); sl@0: Tcl_IncrRefCount(tempPtr); sl@0: sl@0: /* sl@0: * We assume the same name in the current directory is ok. sl@0: */ sl@0: str = Tcl_GetString(pathPtr); sl@0: origPtr = Tcl_NewStringObj(str+10,-1); sl@0: Tcl_IncrRefCount(origPtr); sl@0: sl@0: res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr); sl@0: Tcl_DecrRefCount(origPtr); sl@0: sl@0: if (res != TCL_OK) { sl@0: Tcl_FSDeleteFile(tempPtr); sl@0: Tcl_DecrRefCount(tempPtr); sl@0: return NULL; sl@0: } sl@0: return tempPtr; sl@0: } sl@0: sl@0: static Tcl_Channel sl@0: SimpleOpenFileChannel(interp, pathPtr, mode, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: Tcl_Obj *pathPtr; /* Name of file to open. */ sl@0: int mode; /* POSIX open mode. */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: Tcl_Obj *tempPtr; sl@0: Tcl_Channel chan; sl@0: sl@0: if ((mode != 0) && !(mode & O_RDONLY)) { sl@0: Tcl_AppendResult(interp, "read-only", sl@0: (char *) NULL); sl@0: return NULL; sl@0: } sl@0: sl@0: tempPtr = SimpleCopy(pathPtr); sl@0: sl@0: if (tempPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions); sl@0: sl@0: if (tempFile != NULL) { sl@0: Tcl_FSDeleteFile(tempFile); sl@0: Tcl_DecrRefCount(tempFile); sl@0: tempFile = NULL; sl@0: } sl@0: /* sl@0: * Store file pointer in this global variable so we can delete sl@0: * it later sl@0: */ sl@0: tempFile = tempPtr; sl@0: return chan; sl@0: } sl@0: sl@0: static int sl@0: SimpleAccess(pathPtr, mode) sl@0: Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ sl@0: int mode; /* Permission setting. */ sl@0: { sl@0: /* All files exist */ sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: SimpleStat(pathPtr, bufPtr) sl@0: Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ sl@0: Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ sl@0: { sl@0: Tcl_Obj *tempPtr = SimpleCopy(pathPtr); sl@0: if (tempPtr == NULL) { sl@0: /* We just pretend the file exists anyway */ sl@0: return TCL_OK; sl@0: } else { sl@0: int res = Tcl_FSStat(tempPtr, bufPtr); sl@0: Tcl_FSDeleteFile(tempPtr); sl@0: Tcl_DecrRefCount(tempPtr); sl@0: return res; sl@0: } sl@0: } sl@0: sl@0: static Tcl_Obj* sl@0: SimpleListVolumes(void) sl@0: { sl@0: /* Add one new volume */ sl@0: Tcl_Obj *retVal; sl@0: sl@0: retVal = Tcl_NewStringObj("simplefs:/",-1); sl@0: Tcl_IncrRefCount(retVal); sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: * Used to check correct string-length determining in Tcl_NumUtfChars sl@0: */ sl@0: static int sl@0: TestNumUtfCharsCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; sl@0: Tcl_Interp *interp; sl@0: int objc; sl@0: Tcl_Obj *CONST objv[]; sl@0: { sl@0: if (objc > 1) { sl@0: int len = -1; sl@0: if (objc > 2) { sl@0: (void) Tcl_GetStringFromObj(objv[1], &len); sl@0: } sl@0: len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); sl@0: Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); sl@0: } sl@0: return TCL_OK; sl@0: }