diff options
author | dgp <dgp@users.sourceforge.net> | 2017-03-17 12:51:53 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2017-03-17 12:51:53 (GMT) |
commit | aa3b9b49e082cbda4500eba60787a80c9cfd64e2 (patch) | |
tree | f67519530b2ee952335022154250f726972d334b | |
parent | ba078102bb35ae671db5adb952ee48ecef4003ed (diff) | |
parent | f2882138fdb10093e33cbe23ad4eb5dea4461e6a (diff) | |
download | tcl-aa3b9b49e082cbda4500eba60787a80c9cfd64e2.zip tcl-aa3b9b49e082cbda4500eba60787a80c9cfd64e2.tar.gz tcl-aa3b9b49e082cbda4500eba60787a80c9cfd64e2.tar.bz2 |
merge 8.6
-rw-r--r-- | generic/tclAssembly.c | 20 | ||||
-rw-r--r-- | generic/tclBasic.c | 11 | ||||
-rw-r--r-- | generic/tclClock.c | 22 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 406 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 99 | ||||
-rw-r--r-- | generic/tclCompile.c | 5 | ||||
-rw-r--r-- | generic/tclCompile.h | 4 | ||||
-rw-r--r-- | generic/tclExecute.c | 33 | ||||
-rw-r--r-- | generic/tclInt.h | 12 | ||||
-rw-r--r-- | generic/tclTomMath.h | 12 | ||||
-rw-r--r-- | library/init.tcl | 11 | ||||
-rw-r--r-- | tests/cmdAH.test | 4 | ||||
-rw-r--r-- | tests/interp.test | 2 |
13 files changed, 546 insertions, 95 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f56da8f..120fd9a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -137,6 +137,8 @@ typedef enum TalInstType { * ranges */ ASSEM_BOOL, /* One Boolean operand */ ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ + ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the + * range 0-3 */ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must * be strictly positive, consumes N, produces * 1 */ @@ -350,6 +352,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, + {"clockRead", ASSEM_CLOCK_READ, INST_CLOCK_READ, 0, 1}, {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, @@ -1363,6 +1366,23 @@ AssembleOneLine( TclEmitInt4(localVar, envPtr); break; + case ASSEM_CLOCK_READ: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + if (opnd < 0 || opnd > 3) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operand must be [0..3]", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL); + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); + break; + case ASSEM_CONCAT1: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d6a460d..4bddbce 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -265,7 +265,6 @@ static const CmdInfo builtInCmds[] = { {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -789,16 +788,17 @@ Tcl_CreateInterp(void) } /* - * Create the "array", "binary", "chan", "dict", "file", "info", - * "namespace" and "string" ensembles. Note that all these commands (and - * their subcommands that are not present in the global namespace) are - * wholly safe *except* for "file". + * Create the "array", "binary", "chan", "clock", "dict", "encoding", + * "file", "info", "namespace" and "string" ensembles. Note that all these + * commands (and their subcommands that are not present in the global + * namespace) are wholly safe *except* for "clock", "encoding" and "file". */ TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitEncodingCmd(interp); TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); @@ -1026,6 +1026,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeEncodingCommandSafe(interp); /* Ugh! */ TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } diff --git a/generic/tclClock.c b/generic/tclClock.c index c3b29e9..02b2845 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -208,11 +208,7 @@ struct ClockCommand { }; static const struct ClockCommand clockCommands[] = { - { "clicks", ClockClicksObjCmd }, { "getenv", ClockGetenvObjCmd }, - { "microseconds", ClockMicrosecondsObjCmd }, - { "milliseconds", ClockMillisecondsObjCmd }, - { "seconds", ClockSecondsObjCmd }, { "Oldscan", TclClockOldscanObjCmd }, { "ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd }, { "GetDateFields", ClockGetdatefieldsObjCmd }, @@ -253,6 +249,19 @@ TclClockInit( ClockClientData *data; int i; + /* Structure of the 'clock' ensemble */ + + static const EnsembleImplMap clockImplMap[] = { + {"add", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0}, + {"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0}, + {"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0}, + {"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0}, + {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + /* * Safe interps get [::clock] as alias to a master, so do not need their * own copies of the support routines. @@ -276,6 +285,7 @@ TclClockInit( /* * Install the commands. + * TODO - Let Tcl_MakeEnsemble do this? */ #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ @@ -286,6 +296,10 @@ TclClockInit( Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data, ClockDeleteCmdProc); } + + /* Make the clock ensemble */ + + TclMakeEnsemble(interp, "clock", clockImplMap); } /* diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4c299f8..a48dfc7 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -46,9 +46,24 @@ struct ForeachState { static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); +static int BadEncodingSubcommand(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingConvertfromObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingConverttoObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int EncodingNamesObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingSystemObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -541,79 +556,280 @@ Tcl_EncodingObjCmd( switch ((enum options) index) { case ENC_CONVERTTO: - case ENC_CONVERTFROM: { - Tcl_Obj *data; - Tcl_DString ds; - Tcl_Encoding encoding; - int length; - const char *stringPtr; - - if (objc == 3) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[2]; - } else if (objc == 4) { - if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { - return TCL_ERROR; - } - data = objv[3]; - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); - return TCL_ERROR; - } + return EncodingConverttoObjCmd(dummy, interp, objc, objv); + case ENC_CONVERTFROM: + return EncodingConvertfromObjCmd(dummy, interp, objc, objv); + case ENC_DIRS: + return EncodingDirsObjCmd(dummy, interp, objc, objv); + case ENC_NAMES: + return EncodingNamesObjCmd(dummy, interp, objc, objv); + case ENC_SYSTEM: + return EncodingSystemObjCmd(dummy, interp, objc, objv); + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * TclInitEncodingCmd -- + * + * This function creates the 'encoding' ensemble. + * + * Results: + * Returns the Tcl_Command so created. + * + * Side effects: + * The ensemble is initialized. + * + * This command is hidden in a safe interpreter. + */ - if ((enum options) index == ENC_CONVERTFROM) { - /* - * Treat the string as binary data. - */ +Tcl_Command +TclInitEncodingCmd( + Tcl_Interp* interp) /* Tcl interpreter */ +{ + static const EnsembleImplMap encodingImplMap[] = { + {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; - stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); + return TclMakeEnsemble(interp, "encoding", encodingImplMap); +} + +/* + *----------------------------------------------------------------------------- + * + * TclMakeEncodingCommandSafe -- + * + * This function hides the unsafe 'dirs' and 'system' subcommands of + * the "encoding" Tcl command ensemble. It must be called only from + * TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *----------------------------------------------------------------------------- + */ + +int +TclMakeEncodingCommandSafe( + Tcl_Interp* interp) /* Tcl interpreter */ +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"convertfrom", 0}, + {"convertto", 0}, + {"dirs", 1}, + {"names", 0}, + {"system", 0}, + {NULL, 0} + }; - /* - * Note that we cannot use Tcl_DStringResult here because it will - * truncate the string at the first null byte. - */ + int i; + Tcl_DString oldBuf, newBuf; - Tcl_SetObjResult(interp, TclDStringToObj(&ds)); - } else { - /* - * Store the result as binary data. - */ - - stringPtr = TclGetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); + Tcl_DStringInit(&oldBuf); + TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::"); + Tcl_DStringInit(&newBuf); + TclDStringAppendLiteral(&newBuf, "tcl:encoding:"); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 17); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 13); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'encoding %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); - Tcl_FreeEncoding(encoding); - break; + /* + * Ugh. The [encoding] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. + */ + + if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) { + Tcl_Panic("problem making 'encoding' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); } - case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc, objv); - case ENC_NAMES: - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * BadEncodingSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * "encoding" are unsafe (the real implementations of the subcommands are + * hidden). The clientData is always the full official subcommand name. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadEncodingSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *subcommandName = (const char *) clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of encoding", subcommandName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * EncodingConvertfromObjCmd -- + * + * This command converts a byte array in an external encoding into a + * Tcl string + * + * Results: + * A standard Tcl result. + * + *---------------------------------------------------------------------- + */ + +int +EncodingConvertfromObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *data; /* Byte array to convert */ + Tcl_DString ds; /* Buffer to hold the string */ + Tcl_Encoding encoding; /* Encoding to use */ + int length; /* Length of the byte array being converted */ + const char *bytesPtr; /* Pointer to the first byte of the array */ + + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if (objc == 3) { + if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } - Tcl_GetEncodingNames(interp); - break; - case ENC_SYSTEM: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + data = objv[2]; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + return TCL_ERROR; + } + + /* + * Convert the string into a byte array in 'ds' + */ + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because it will + * truncate the string at the first null byte. + */ + + Tcl_SetObjResult(interp, TclDStringToObj(&ds)); + + /* + * We're done with the encoding + */ + + Tcl_FreeEncoding(encoding); + return TCL_OK; + +} + +/* + *---------------------------------------------------------------------- + * + * EncodingConverttoObjCmd -- + * + * This command converts a Tcl string into a byte array that + * encodes the string according to some encoding. + * + * Results: + * A standard Tcl result. + * + *---------------------------------------------------------------------- + */ + +int +EncodingConverttoObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *data; /* String to convert */ + Tcl_DString ds; /* Buffer to hold the byte array */ + Tcl_Encoding encoding; /* Encoding to use */ + int length; /* Length of the string being converted */ + const char *stringPtr; /* Pointer to the first byte of the string */ + + /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ + + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if (objc == 3) { + if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } - if (objc == 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetEncodingName(NULL), -1)); - } else { - return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); - } - break; + data = objv[2]; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + return TCL_ERROR; } + + /* + * Convert the string to a byte array in 'ds' + */ + + stringPtr = TclGetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + + /* + * We're done with the encoding + */ + + Tcl_FreeEncoding(encoding); return TCL_OK; + } /* @@ -641,16 +857,16 @@ EncodingDirsObjCmd( { Tcl_Obj *dirListObj; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?dirList?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); return TCL_ERROR; } - if (objc == 2) { + if (objc == 1) { Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); return TCL_OK; } - dirListObj = objv[2]; + dirListObj = objv[1]; if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected directory list but got \"%s\"", @@ -664,6 +880,68 @@ EncodingDirsObjCmd( } /* + *----------------------------------------------------------------------------- + * + * EncodingNamesObjCmd -- + * + * This command returns a list of the available encoding names + * + * Results: + * Returns a standard Tcl result + * + *----------------------------------------------------------------------------- + */ + +int +EncodingNamesObjCmd(ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ +{ + if (objc > 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * EncodingSystemObjCmd -- + * + * This command retrieves or changes the system encoding + * + * Results: + * Returns a standard Tcl result + * + * Side effects: + * May change the system encoding. + * + *----------------------------------------------------------------------------- + */ + +int +EncodingSystemObjCmd(ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1)); + } else { + return Tcl_SetSystemEncoding(interp, TclGetString(objv[1])); + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * Tcl_ErrorObjCmd -- diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7dba232..c2b4bdb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -734,6 +734,105 @@ TclCompileCatchCmd( return TCL_OK; } +/*---------------------------------------------------------------------- + * + * TclCompileClockClicksCmd -- + * + * Procedure called to compile the "tcl::clock::clicks" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileClockClicksCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token* tokenPtr; + + switch (parsePtr->numWords) { + case 1: + /* + * No args + */ + TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); + break; + case 2: + /* + * -milliseconds or -microseconds + */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD + || tokenPtr[1].size < 4 + || tokenPtr[1].size > 13) { + return TCL_ERROR; + } else if (!strncmp(tokenPtr[1].start, "-microseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); + break; + } else if (!strncmp(tokenPtr[1].start, "-milliseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); + break; + } else { + return TCL_ERROR; + } + default: + return TCL_ERROR; + } + return TCL_OK; +} + + +/*---------------------------------------------------------------------- + * + * TclCompileClockReadingCmd -- + * + * Procedure called to compile the "tcl::clock::microseconds", + * "tcl::clock::milliseconds" and "tcl::clock::seconds" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds. + *---------------------------------------------------------------------- + */ + +int +TclCompileClockReadingCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); + + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f6b3c52..f716195 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -654,6 +654,11 @@ InstructionDesc const tclInstructionTable[] = { /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ + {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, + /* Read clock out to the stack. Operand is which clock to read + * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. + * Stack: ... => ... time */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ba6ad44..e5d026c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -821,8 +821,10 @@ typedef struct ByteCode { #define INST_LAPPEND_LIST_ARRAY_STK 187 #define INST_LAPPEND_LIST_STK 188 +#define INST_CLOCK_READ 189 + /* The last opcode */ -#define LAST_INST_OPCODE 188 +#define LAST_INST_OPCODE 189 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1d3a825..cb4e6dc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7840,6 +7840,39 @@ TEBCresume( * ----------------------------------------------------------------- */ + case INST_CLOCK_READ: + { /* Read the wall clock */ + Tcl_WideInt wval; + Tcl_Time now; + switch(TclGetUInt1AtPtr(pc+1)) { + case 0: /* clicks */ +#ifdef TCL_WIDE_CLICKS + wval = TclpGetWideClicks(); +#else + wval = (Tcl_WideInt) TclpGetClicks(); +#endif + break; + case 1: /* microseconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec * 1000000 + now.usec; + break; + case 2: /* milliseconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + break; + case 3: /* seconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec; + break; + default: + Tcl_Panic("clockRead instruction with unknown clock#"); + } + /* TclNewWideObj(objResultPtr, wval); doesn't exist */ + objResultPtr = Tcl_NewWideIntObj(wval); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(2, 0, 1); + } + default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 4d3c0b1..1deda3c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3239,10 +3239,8 @@ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3480,6 +3478,12 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index c1d83c4..41512f0 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -87,7 +87,7 @@ extern "C" { # define DIGIT_BIT 60 #else /* this is the default case, 28-bit digits */ - + /* this is to make porting into LibTomCrypt easier :-) */ #ifndef CRYPT # if defined(_MSC_VER) || defined(__BORLANDC__) @@ -105,14 +105,14 @@ extern "C" { #endif typedef ulong64 mp_word; -#ifdef MP_31BIT +#ifdef MP_31BIT /* this is an extension that uses 31-bit digits */ # define DIGIT_BIT 31 #else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ # define DIGIT_BIT 28 # define MP_28BIT -#endif +#endif #endif /* define heap macros */ @@ -646,7 +646,7 @@ int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); */ /* This gives [for a given bit size] the number of trials required - * such that Miller-Rabin gives a prob of failure lower than 2^-96 + * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* int mp_prime_rabin_miller_trials(int size); @@ -673,7 +673,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); */ /* makes a truly random prime of a given size (bytes), - * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself @@ -686,7 +686,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); /* makes a truly random prime of a given size (bits), * * Flags are as follows: - * + * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero diff --git a/library/init.tcl b/library/init.tcl index 0437412..471a9d8 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -169,13 +169,7 @@ if {[interp issafe]} { namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] - proc clock args { - namespace eval ::tcl::clock [list namespace ensemble create -command \ - [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ - -subcommands { - add clicks format microseconds milliseconds scan seconds - }] - + proc ::tcl::initClock {} { # Auto-loading stubs for 'clock.tcl' foreach cmd {add format scan} { @@ -186,8 +180,9 @@ if {[interp issafe]} { } } - return [uplevel 1 [info level 0]] + rename ::tcl::initClock {} } + ::tcl::initClock } # Conditionalize for presence of exec. diff --git a/tests/cmdAH.test b/tests/cmdAH.test index b4ef605..3c58c1b 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -167,10 +167,10 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto } -result {wrong # args: should be "encoding convertto ?encoding? data"} diff --git a/tests/interp.test b/tests/interp.test index 6000ffd..4d61e35 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} foreach i [interp slaves] { interp delete $i |