diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 154 |
1 files changed, 154 insertions, 0 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 9284969..8d106f9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -273,6 +273,7 @@ static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; +static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; @@ -656,6 +657,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); @@ -3425,6 +3427,158 @@ TestlinkarrayCmd( /* *---------------------------------------------------------------------- * + * TestlistrepCmd -- + * + * This function is invoked to generate a list object with a specific + * internal representation. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestlistrepCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* Subcommands supported by this command */ + const char* subcommands[] = { + "new", + "describe", + "config", + "validate", + NULL + }; + enum { + LISTREP_NEW, + LISTREP_DESCRIBE, + LISTREP_CONFIG, + LISTREP_VALIDATE + } cmdIndex; + Tcl_Obj *resultObj = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj( + interp, objv[1], subcommands, "command", 0, &cmdIndex) + != TCL_OK) { + return TCL_ERROR; + } + switch (cmdIndex) { + case LISTREP_NEW: + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?"); + return TCL_ERROR; + } else { + int length; + int leadSpace = 0; + int endSpace = 0; + if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 3) { + if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 4) { + if (Tcl_GetIntFromObj(interp, objv[4], &endSpace) + != TCL_OK) { + return TCL_ERROR; + } + } + } + resultObj = TclListTestObj(length, leadSpace, endSpace); + } + break; + + case LISTREP_DESCRIBE: +#define APPEND_FIELD(targetObj_, structPtr_, fld_) \ + do { \ + Tcl_ListObjAppendElement( \ + interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \ + Tcl_ListObjAppendElement( \ + interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \ + } while (0) + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } else { + Tcl_Obj **objs; + ListSizeT nobjs; + ListRep listRep; + Tcl_Obj *listRepObjs[4]; + + /* Force list representation */ + if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) { + return TCL_ERROR; + } + ListObjGetRep(objv[2], &listRep); + listRepObjs[0] = Tcl_NewStringObj("store", -1); + listRepObjs[1] = Tcl_NewListObj(12, NULL); + Tcl_ListObjAppendElement( + interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1)); + Tcl_ListObjAppendElement( + interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr)); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags); + if (listRep.spanPtr) { + listRepObjs[2] = Tcl_NewStringObj("span", -1); + listRepObjs[3] = Tcl_NewListObj(8, NULL); + Tcl_ListObjAppendElement(interp, + listRepObjs[3], + Tcl_NewStringObj("memoryAddress", -1)); + Tcl_ListObjAppendElement( + interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr)); + APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart); + APPEND_FIELD( + listRepObjs[3], listRep.spanPtr, spanLength); + APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount); + } + resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs); + } +#undef APPEND_FIELD + break; + + case LISTREP_CONFIG: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } + resultObj = Tcl_NewListObj(2, NULL); + Tcl_ListObjAppendElement( + NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1)); + Tcl_ListObjAppendElement( + NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD)); + break; + + case LISTREP_VALIDATE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } + TclListObjValidate(interp, objv[2]); /* Panics if invalid */ + resultObj = Tcl_NewObj(); + break; + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestlocaleCmd -- * * This procedure implements the "testlocale" command. It is used |