Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Comment: | merge trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | novem |
Files: | files | file ages | folders |
SHA1: |
7c19121b2ecb19ef0a532403092444b1 |
User & Date: | dgp 2013-09-21 12:49:59 |
2013-09-23
| ||
20:04 | merge trunk check-in: 6ec1685ef4 user: jan.nijtmans tags: novem | |
2013-09-21
| ||
12:49 | merge trunk check-in: 7c19121b2e user: dgp tags: novem | |
2013-09-20
| ||
09:11 | Make sure that panic's during finalization are handled by the custom panicproc not by the default pa... check-in: d7d7d0857d user: jan.nijtmans tags: trunk | |
05:28 | merge release check-in: 63009ab07c user: dgp tags: trunk | |
2013-09-19
| ||
22:37 | [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. check-in: af5c35971a user: dkf tags: trunk | |
2013-08-14
| ||
14:40 | merge trunk check-in: e24c4b1f62 user: jan.nijtmans tags: novem | |
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2013-08-03 Donal Fellows <[email protected]> * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found by the autoloading mechanism. 2013-08-02 Donal Fellows <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | 2013-09-19 Donal Fellows <[email protected]> * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected description of method search order. 2013-09-18 Donal Fellows <[email protected]> Bump TclOO version to 1.0.1 for release. 2013-09-17 Donal Fellows <[email protected]> * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: Corrected implementation of the core of uuencode handling so that the line length processing is correctly applied. ***POTENTIAL INCOMPATIBILITY*** Existing code that was using the old versions and working around the limitations will now need to do far less. The -maxlen option now has strict limits on the range of supported lengths; this is a limitation of the format itself. 2013-09-09 Donal Fellows <[email protected]> * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip the internal representation of method bodies during cloning in order to ensure that any bound references to instance variables are removed. 2013-09-01 Donal Fellows <[email protected]> * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that whitespace at the end of a string don't cause the decoder to drop the last decoded byte. 2013-08-03 Donal Fellows <[email protected]> * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found by the autoloading mechanism. 2013-08-02 Donal Fellows <[email protected]> |
︙ | ︙ | |||
32 33 34 35 36 37 38 | 2013-07-02 Jan Nijtmans <[email protected]> * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4 * unix/configure: (thanks to Brian Griffin) 2013-06-27 Jan Nijtmans <[email protected]> | | | | > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | 2013-07-02 Jan Nijtmans <[email protected]> * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4 * unix/configure: (thanks to Brian Griffin) 2013-06-27 Jan Nijtmans <[email protected]> * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs * generic/tclMain.c: initialized encodings. 2013-06-18 Jan Nijtmans <[email protected]> * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. 2013-06-17 Jan Nijtmans <[email protected]> * generic/regc_locale.c: Bug [a876646efe]: re_expr character class [:cntrl:] should contain \u0000 - \u001f 2013-06-09 Donal K. Fellows <[email protected]> |
︙ | ︙ | |||
149 150 151 152 153 154 155 | command with expansion ([list {*}blah]) into bytecode that does not call an external command. 2013-05-06 Jan Nijtmans <[email protected]> * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 | | | | | | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | command with expansion ([list {*}blah]) into bytecode that does not call an external command. 2013-05-06 Jan Nijtmans <[email protected]> * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 requires that all stub entries use 32-bit long's, therefore the need for various wrapper functions/macros. For Tcl 9 a better solution is needed, but that cannot be done without introducing binary incompatibility. 2013-04-30 Andreas Kupries <[email protected]> * library/platform/platform.tcl (::platform::LibcVersion): * library/platform/pkgIndex.tcl: Followup to the 2013-01-30 change. The RE become too restrictive again. SuSe added a timestamp after the version. Loosened up a bit. Bumped package to version 1.0.12. 2013-04-29 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileArraySetCmd): Generate better code when the list of things to set is a literal. 2013-04-25 Jan Nijtmans <[email protected]> * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it only eliminates code duplication. * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's exactly the same as TCL_WIDE_INT_IS_LONG 2013-04-19 Jan Nijtmans <[email protected]> * generic/tclDecls.h: Implement many Tcl_*Var* functions and Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp their |
︙ | ︙ |
Changes to doc/AddErrInfo.3.
︙ | ︙ | |||
172 173 174 175 176 177 178 | the stack trace text they append to the \fB\-errorinfo\fR option. Tcl provides several simpler interfaces to more directly set these return options. .PP The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. | | | | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 | the stack trace text they append to the \fB\-errorinfo\fR option. Tcl provides several simpler interfaces to more directly set these return options. .PP The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. The \fB\-errorcode\fR option holds a Tcl list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred (e.g., POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. See the manual entry on the \fBerrorCode\fR variable for details on the various formats for the \fB\-errorcode\fR option used by Tcl's built-in commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. Each time an error code is returned to \fBTcl_Eval\fR, or any of the routines that performs script evaluation, the procedure \fBTcl_AddErrorInfo\fR is called to add additional text to the \fB\-errorinfo\fR value describing the |
︙ | ︙ | |||
303 304 305 306 307 308 309 | occurred after all. The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), | | | 303 304 305 306 307 308 309 310 311 312 | occurred after all. The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), errorCode(n), errorInfo(n) .SH KEYWORDS error, value, value result, stack, trace, variable |
Changes to doc/CrtInterp.3.
︙ | ︙ | |||
37 38 39 40 41 42 43 | a token for it. The token is required in calls to most other Tcl procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and \fBTcl_DeleteInterp\fR. The token returned by \fBTcl_CreateInterp\fR may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands | | | > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | a token for it. The token is required in calls to most other Tcl procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and \fBTcl_DeleteInterp\fR. The token returned by \fBTcl_CreateInterp\fR may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To bind in additional commands, call \fBTcl_CreateCommand\fR, and to create additional variables, call \fBTcl_SetVar\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have been matched by calls to \fBTcl_Release\fR. At that time, all of the resources associated with it, including variables, procedures, and application-specific command bindings, will be deleted. After \fBTcl_DeleteInterp\fR returns any attempt to use \fBTcl_Eval\fR on the |
︙ | ︙ | |||
139 140 141 142 143 144 145 | .VS 8.6 Note that the protection mechanisms do not work well with conventional garbage collection systems. When in such a managed environment, \fBTcl_InterpActive\fR should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" | | | 140 141 142 143 144 145 146 147 148 149 | .VS 8.6 Note that the protection mechanisms do not work well with conventional garbage collection systems. When in such a managed environment, \fBTcl_InterpActive\fR should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter |
Changes to doc/Environment.3.
︙ | ︙ | |||
29 30 31 32 33 34 35 | .QW \fINAME\fB=\fIvalue\fR . This procedure is intended to be a stand-in for the UNIX \fBputenv\fR system call. All Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" | | | 29 30 31 32 33 34 35 36 37 38 | .QW \fINAME\fB=\fIvalue\fR . This procedure is intended to be a stand-in for the UNIX \fBputenv\fR system call. All Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" env(n) .SH KEYWORDS environment, variable |
Changes to doc/Method.3.
︙ | ︙ | |||
168 169 170 171 172 173 174 | Tcl_MethodDeleteProc *\fIdeleteProc\fR; Tcl_CloneProc *\fIcloneProc\fR; } \fBTcl_MethodType\fR; .CE .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The | | | > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | Tcl_MethodDeleteProc *\fIdeleteProc\fR; Tcl_CloneProc *\fIcloneProc\fR; } \fBTcl_MethodType\fR; .CE .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The \fIname\fR field provides a human-readable name for the type, and is the value that is exposed via the \fBinfo class methodtype\fR and \fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. .PP The \fIdeleteProc\fR field gives a function that is used to delete a particular method, and is called when the method is replaced or removed; if the field is NULL, it is assumed that the method's \fIclientData\fR needs no |
︙ | ︙ |
Changes to doc/NRE.3.
1 2 3 4 5 6 7 8 9 10 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Command \fBTcl_NRCreateCommand\fR(\fIinterp, cmdName, proc, nreProc, clientData, deleteProc\fR) |
︙ | ︙ | |||
203 204 205 206 207 208 209 | .SH EXAMPLE .PP The usual pattern for Tcl commands that invoke other Tcl commands is something like: .PP .CS int | | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | .SH EXAMPLE .PP The usual pattern for Tcl commands that invoke other Tcl commands is something like: .PP .CS int \fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int result; Tcl_Obj *objPtr; \fI... preparation ...\fR result = \fBTcl_EvalObjEx\fR(interp, objPtr, 0); \fI... postprocessing ...\fR return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, it must be split into three pieces: .IP \(bu A non-trampoline implementation, \fITheCmdNewObjProc\fR, which will simply create a trampoline |
︙ | ︙ | |||
251 252 253 254 255 256 257 | int \fITheCmdNewObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { | | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | int \fITheCmdNewObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, clientData, objc, objv); } .CE .PP The trampoline-enabled implementation requests postprocessing, and returns to the trampoline requesting command evaluation. .PP .CS |
︙ | ︙ | |||
313 314 315 316 317 318 319 | \fBTcl_NRCreateCommand\fR is used in place of \fBTcl_CreateObjCommand\fR. It accepts two command procedures instead of one. The first is for use when no trampoline is yet on the stack, and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 | \fBTcl_NRCreateCommand\fR is used in place of \fBTcl_CreateObjCommand\fR. It accepts two command procedures instead of one. The first is for use when no trampoline is yet on the stack, and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT Copyright (c) 2008 by Kevin B. Kenny |
Changes to doc/bgerror.n.
︙ | ︙ | |||
81 82 83 84 85 86 87 | set timestamp [clock format [clock seconds]] set fl [open mylog.txt {WRONLY CREAT APPEND}] puts $fl "$timestamp: bgerror in $::argv '$message'" close $fl } .CE .SH "SEE ALSO" | | > > > | 81 82 83 84 85 86 87 88 89 90 91 92 93 | set timestamp [clock format [clock seconds]] set fl [open mylog.txt {WRONLY CREAT APPEND}] puts $fl "$timestamp: bgerror in $::argv '$message'" close $fl } .CE .SH "SEE ALSO" after(n), errorCode(n), errorInfo(n), interp(n) .SH KEYWORDS background error, reporting '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/binary.n.
︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 | \fBbinary scan\fR, does the opposite: it extracts data from a binary string and returns it as ordinary Tcl string values. .VS 8.6 The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been encoded can be converted back to binary form using \fBbinary decode\fR. The | > > > > > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | \fBbinary scan\fR, does the opposite: it extracts data from a binary string and returns it as ordinary Tcl string values. .VS 8.6 The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 .PP Note that other operations on binary data, such as taking a subsequence of it, getting its length, or reinterpreting it as a string in some encoding, are done by other Tcl commands (respectively \fBstring range\fR, \fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A binary string in Tcl is merely one where all the characters it contains are in the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been encoded can be converted back to binary form using \fBbinary decode\fR. The |
︙ | ︙ | |||
91 92 93 94 95 96 97 | \fBuuencode\fR . The \fBuuencode\fR binary encoding used to be common for transfer of data between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP | | | | > | > > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | \fBuuencode\fR . The \fBuuencode\fR binary encoding used to be common for transfer of data between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP During encoding, the following options are supported (though changing them may produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are split every 61 characters, and this must be in the range 3 to 85 due to limitations in the encoding. .TP \fB\-wrapchar \fIcharacter\fR . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a newline character, .QW \en . .PP During decoding, the following options are supported: .TP \fB\-strict\fR . Instructs the decoder to throw an error if it encounters unexpected whitespace characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of the uuencode format. .RE .VE 8.6 .SH "BINARY FORMAT" .PP The \fBbinary format\fR command generates a binary string whose layout is specified by the \fIformatString\fR and whose contents come from the additional arguments. The resulting binary value is returned. |
︙ | ︙ | |||
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 | universal. To transfer floating-point numbers portably between all architectures, use their textual representation (as produced by \fBformat\fR) instead. .SH EXAMPLES .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] puts -nonewline [\fBbinary format\fR Ia* \e [string length $data] $data] } .CE .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { error "missing length" } set data [read $channel $length] return [encoding convertfrom utf-8 $data] } .CE .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: .CS set f [open $filename rb] set data [read $f] close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" | > > > | > | 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 | universal. To transfer floating-point numbers portably between all architectures, use their textual representation (as produced by \fBformat\fR) instead. .SH EXAMPLES .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: .PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] puts -nonewline [\fBbinary format\fR Ia* \e [string length $data] $data] } .CE .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: .PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { error "missing length" } set data [read $channel $length] return [encoding convertfrom utf-8 $data] } .CE .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: .PP .CS set f [open $filename rb] set data [read $f] close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" encoding(n), format(n), scan(n), string(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/catch.n.
︙ | ︙ | |||
111 112 113 114 115 116 117 | exit 1 } .CE .PP There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" | | > | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | exit 1 } .CE .PP There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), return(n) .SH KEYWORDS catch, error, exception '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/eval.n.
︙ | ︙ | |||
71 72 73 74 75 76 77 | However, the last line would now normally be written without \fBeval\fR, like this: .PP .CS set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" | > | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | However, the last line would now normally be written without \fBeval\fR, like this: .PP .CS set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), namespace(n), subst(n), uplevel(n) .SH KEYWORDS concatenate, evaluate, script '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/info.n.
︙ | ︙ | |||
292 293 294 295 296 297 298 | .TP \fBinfo library\fR . Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. | < | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 | .TP \fBinfo library\fR . Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. .TP \fBinfo loaded \fR?\fIinterp\fR? . Returns a list describing all of the packages that have been loaded into \fIinterp\fR with the \fBload\fR command. Each list element is a sub-list with two elements consisting of the name of the file from which the package was loaded and the name of |
︙ | ︙ | |||
332 333 334 335 336 337 338 | .VS 8.6 Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are described in \fBOBJECT INTROSPECTION\fR below. .VE 8.6 .TP \fBinfo patchlevel\fR . | | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 | .VS 8.6 Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are described in \fBOBJECT INTROSPECTION\fR below. .VE 8.6 .TP \fBinfo patchlevel\fR . Returns the value of the global variable \fBtcl_patchLevel\fR, which holds the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . If \fIpattern\fR is not specified, returns a list of all the names of Tcl command procedures in the current namespace. If \fIpattern\fR is specified, only those procedure names in the current namespace |
︙ | ︙ | |||
370 371 372 373 374 375 376 | Returns the extension used on this platform for the names of files containing shared libraries (for example, \fB.so\fR under Solaris). If shared libraries are not supported on this platform then an empty string is returned. .TP \fBinfo tclversion\fR . | | | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | Returns the extension used on this platform for the names of files containing shared libraries (for example, \fB.so\fR under Solaris). If shared libraries are not supported on this platform then an empty string is returned. .TP \fBinfo tclversion\fR . Returns the value of the global variable \fBtcl_version\fR, which holds the major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . If \fIpattern\fR is not specified, returns a list of all the names of currently-visible variables. This includes locals and currently-visible globals. If \fIpattern\fR is specified, only those names matching \fIpattern\fR |
︙ | ︙ | |||
759 760 761 762 763 764 765 | # Assume no forwards return [\fBinfo class definition\fR $cls $method] } .CE .VE 8.6 .SH "SEE ALSO" .VS 8.6 | | > | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 | # Assume no forwards return [\fBinfo class definition\fR $cls $method] } .CE .VE 8.6 .SH "SEE ALSO" .VS 8.6 global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), .VE 8.6 tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, .VS 8.6 object, .VE 8.6 procedure, variable '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/library.n.
︙ | ︙ | |||
258 259 260 261 262 263 264 265 | any commands. .TP \fBauto_noload\fR If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR If set, then it must contain a valid Tcl list giving directories to | > | > | > > | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | any commands. .TP \fBauto_noload\fR If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR . If set, then it must contain a valid Tcl list giving directories to search during auto-load operations (including for package index files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. Additional locations to look for files and package indices should normally be added to this variable using \fBlappend\fR. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing library scripts (the value of this variable will be assigned to the \fBtcl_library\fR variable and therefore returned by the command \fBinfo library\fR). If this variable is not set then a default value is used. |
︙ | ︙ | |||
302 303 304 305 306 307 308 | This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 | This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/next.n.
︙ | ︙ | |||
58 59 60 61 62 63 64 | .IP [5] The method chain is cached for future use. .SS "METHOD SEARCH ORDER" .PP When constructing the method chain, method implementations are searched for in the following order: .IP [1] | < < | > > | > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | .IP [5] The method chain is cached for future use. .SS "METHOD SEARCH ORDER" .PP When constructing the method chain, method implementations are searched for in the following order: .IP [1] In the classes mixed into the object, in class traversal order. The list of mixins is checked in natural order. .IP [2] In the classes mixed into the classes of the object, with sources of mixing in being searched in class traversal order. Within each class, the list of mixins is processed in natural order. .IP [3] In the object itself. .IP [4] In the object's class. .IP [5] In the superclasses of the class, following each superclass in a depth-first fashion in the natural order of the superclass list. .PP Any particular method implementation always comes as \fIlate\fR in the resulting list of implementations as possible; this means that if some class, A, is both mixed into a class, B, and is also a superclass of B, the instances of B will always treat A as a superclass from the perspective of inheritance. This is true even when the multiple inheritance is processed indirectly. .SS FILTERS .PP When an object has a list of filter names set upon it, or is an instance of a class (or has mixed in a class) that has a list of filter names set upon it, before every invocation of any method the filters are processed. Filter implementations are found in class traversal order, as are the lists of filter names (each of which is traversed in natural list order). Explicitly invoking |
︙ | ︙ |
Changes to doc/return.n.
︙ | ︙ | |||
313 314 315 316 317 318 319 | } set options [dict merge {-level 1} $args] dict incr options -level \fBreturn\fR -options $options $result } .CE .SH "SEE ALSO" | | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | } set options [dict merge {-level 1} $args] dict incr options -level \fBreturn\fR -options $options $result } .CE .SH "SEE ALSO" break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), proc(n), source(n), throw(n), try(n) .SH KEYWORDS break, catch, continue, error, exception, procedure, result, return .\" Local Variables: .\" mode: nroff .\" End: |
Changes to doc/tclsh.1.
︙ | ︙ | |||
98 99 100 101 102 103 104 | You should note that it is also common practice to install tclsh with its version number as part of the name. This has the advantage of allowing multiple versions of Tcl to exist on the same system at once, but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP | | > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | You should note that it is also common practice to install tclsh with its version number as part of the name. This has the advantage of allowing multiple versions of Tcl to exist on the same system at once, but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP \fBTclsh\fR sets the following global Tcl variables in addition to those created by the Tcl library itself (such as \fBenv\fR, which maps environment variables such as \fBPATH\fR into Tcl): .TP 15 \fBargc\fR . Contains a count of the number of \fIarg\fR arguments (0 if none), not including the name of the script file. .TP 15 \fBargv\fR |
︙ | ︙ | |||
125 126 127 128 129 130 131 | \fIfileName\fR was specified and standard input is a terminal-like device), 0 otherwise. .SH PROMPTS .PP When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . | | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | \fIfileName\fR was specified and standard input is a terminal-like device), 0 otherwise. .SH PROMPTS .PP When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . You can change the prompt by setting the global variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR will evaluate the script in \fBtcl_prompt1\fR. The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command is not yet complete; if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell |
Changes to doc/throw.n.
︙ | ︙ | |||
36 37 38 39 40 41 42 | The following produces an error that is identical to that produced by \fBexpr\fR when trying to divide a value by zero. .PP .CS \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} .CE .SH "SEE ALSO" | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 | The following produces an error that is identical to that produced by \fBexpr\fR when trying to divide a value by zero. .PP .CS \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} .CE .SH "SEE ALSO" catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) .SH "KEYWORDS" error, exception '\" Local Variables: '\" mode: nroff '\" End: |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 | bb->predecessor = NULL; bb->successor1 = NULL; bb->jumpTarget = NULL; bb->initialStackDepth = 0; bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; bb->foreignExceptions = NULL; bb->jtPtr = NULL; bb->flags = 0; | > | 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 | bb->predecessor = NULL; bb->successor1 = NULL; bb->jumpTarget = NULL; bb->initialStackDepth = 0; bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; bb->foreignExceptions = NULL; bb->jtPtr = NULL; bb->flags = 0; |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
117 118 119 120 121 122 123 | static Tcl_ObjCmdProc ExprWideFunc; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); | < | > > > | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | static Tcl_ObjCmdProc ExprWideFunc; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, Tcl_Obj *namePtr, Namespace *lookupNsPtr); static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; /* * Magical counts for the number of arguments accepted by a coroutine command * after particular kinds of [yield]. */ |
︙ | ︙ | |||
2138 2139 2140 2141 2142 2143 2144 | * Define a new object-based command in a command table. * * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: | | < < < < | > | 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 | * Define a new object-based command in a command table. * * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * |
︙ | ︙ | |||
2210 2211 2212 2213 2214 2215 2216 2217 | } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); TclInvalidateNsPath(nsPtr); if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); /* | > > < < | > > > > | > > > < < | 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 | } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); TclInvalidateNsPath(nsPtr); if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); /* Command already exists. */ /* * [***] This is wrong. See Tcl Bug a16752c252. * However, this buggy behavior is kept under particular * circumstances to accommodate deployed binaries of the * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ * that crash if the bug is fixed. */ if (cmdPtr->objProc == TclInvokeStringCommand && cmdPtr->clientData == clientData && cmdPtr->deleteData == clientData && cmdPtr->deleteProc == deleteProc) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; return (Tcl_Command) cmdPtr; } /* * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain |
︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 | * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: * A standard Tcl result value. * * Side effects: | | | | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 | * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ int TclInvokeObjectCommand( ClientData clientData, /* Points to command's Command structure. */ |
︙ | ︙ | |||
3716 3717 3718 3719 3720 3721 3722 | * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and * TCL_EVAL_NOERR are currently supported. */ Command *cmdPtr) /* NULL if the Command is to be looked up * here, otherwise the pointer to the * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; | < < < < | < < < < < < < < < | > > | < < | > > > > > | | < > > > > > > | < > > > > > > > > > > > > < | | > > > > > > > > > | < > > | < | | | > > > | > > | > > > > > > > > > > > > > > > > > > > | | | | | | > > | > > > > | > | > > | > | < > > > > > > > | > > | | | > | | > | > > > > | > > > > > | | | > | | > > > | | | > > > > > | > > > > > | > | < < < < < | < < < < < < < < < < < | < | 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 | * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and * TCL_EVAL_NOERR are currently supported. */ Command *cmdPtr) /* NULL if the Command is to be looked up * here, otherwise the pointer to the * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; /* * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. */ if (iPtr->deferredCallbacks) { iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); } iPtr->numLevels++; TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), INT2PTR(objc), objv); return TCL_OK; } static int EvalObjvCore( ClientData data[], Tcl_Interp *interp, int result) { Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). */ if (!(flags & TCL_EVAL_NOERR)) { TEOV_PushExceptionHandlers(interp, objc, objv, flags); } if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; } if (objc == 0) { return TCL_OK; } if (TclLimitExceeded(iPtr->limit)) { return TCL_ERROR; } /* * Configure evaluation context to match the requested flags. */ if (iPtr->lookupNsPtr) { /* * Capture the namespace we should do command name resolution in, as * instructed by our caller sneaking it in to us in a private interp * field. Clear that field right away so we cannot possibly have its * use leak where it should not. The sneaky message pass is done. * * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. * TODO: Is that a bug? */ lookupNsPtr = iPtr->lookupNsPtr; iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; } else { /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ iPtr->ensembleRewrite.sourceObjs = NULL; if (flags & TCL_EVAL_GLOBAL) { TEOV_SwitchVarFrame(interp); lookupNsPtr = iPtr->globalNsPtr; } } /* * Lookup the Command to dispatch. */ reresolve: assert(cmdPtr == NULL); if (preCmdPtr) { /* Caller gave it to us */ if (!(preCmdPtr->flags & CMD_IS_DELETED)) { /* So long as it exists, use it. */ cmdPtr = preCmdPtr; } else if (flags & TCL_EVAL_NORESOLVE) { /* * When it's been deleted, and we're told not to attempt * resolving it ourselves, all we can do is raise an error. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); return TCL_ERROR; } } if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } } if (enterTracesDone || iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); Tcl_IncrRefCount(commandPtr); if (!enterTracesDone) { int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, objc, objv); /* * Send any exception from enter traces back as an exception * raised by the traced command. * TODO: Is this a bug? Letting an execution trace BREAK or * CONTINUE or RETURN in the place of the traced command? * Would either converting all exceptions to TCL_ERROR, or * just swallowing them be better? (Swallowing them has the * problem of permanently hiding program errors.) */ if (code != TCL_OK) { Tcl_DecrRefCount(commandPtr); return code; } /* * If the enter traces made the resolved cmdPtr unusable, go * back and resolve again, but next time don't run enter * traces again. */ if (cmdPtr == NULL) { enterTracesDone = 1; Tcl_DecrRefCount(commandPtr); goto reresolve; } } /* * Schedule leave traces. Raise the refCount on the resolved * cmdPtr, so that when it passes to the leave traces we know * it's still valid. */ cmdPtr->refCount++; TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); return TCL_OK; } static int Dispatch( ClientData data[], Tcl_Interp *interp, int result) { Tcl_ObjCmdProc *objProc = data[0]; ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; while (i < 10) { a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; } TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); const char *a[6]; int i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } int TclNRRunCallbacks( Tcl_Interp *interp, int result, struct NRE_callback *rootPtr) |
︙ | ︙ | |||
3897 3898 3899 3900 3901 3902 3903 | static int NRCommand( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; | < < < < < | | 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 | static int NRCommand( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; iPtr->numLevels--; /* * If there is a tailcall, schedule it */ if (data[1] && (data[1] != INT2PTR(1))) { TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); |
︙ | ︙ | |||
3930 3931 3932 3933 3934 3935 3936 | } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { result = Tcl_LimitCheck(interp); } return result; } | < < < < < < < < < < < < < < < < | 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 | } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { result = Tcl_LimitCheck(interp); } return result; } /* *---------------------------------------------------------------------- * * TEOV_Exception - * TEOV_LookupCmdFromObj - * TEOV_RunEnterTraces - |
︙ | ︙ | |||
4211 4212 4213 4214 4215 4216 4217 | static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, | | < < | < < | < < | | | < | < | | > > | | | | | < < < < | < | | < < | < < < | | > < > > > > > > > > > | > < | 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 | static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the * command's reference count for the duration of the calling of the * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; if (iPtr->tracePtr) { traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { Tcl_Obj *info; TclNewLiteralStringObj(info, "\n (enter trace on \""); Tcl_AppendLimitedToObj(info, command, length, 55, "..."); Tcl_AppendToObj(info, "\")", 2); Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } return traceCode; } if (cmdEpoch != newEpoch) { *cmdPtrPtr = NULL; } return TCL_OK; } static int TEOV_RunLeaveTraces( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; int traceCode = TCL_OK; int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; int length; const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. * Prevent that by resetting the cmdPtr field and dealing right here with * cmdPtr->refCount. */ TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { Tcl_Obj *info; TclNewLiteralStringObj(info, "\n (leave trace on \""); Tcl_AppendLimitedToObj(info, command, length, 55, "..."); Tcl_AppendToObj(info, "\")", 2); Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } result = traceCode; } Tcl_DecrRefCount(commandPtr); return result; } static inline Command * TEOV_LookupCmdFromObj( Tcl_Interp *interp, Tcl_Obj *namePtr, Namespace *lookupNsPtr) { Interp *iPtr = (Interp *) interp; Command *cmdPtr; Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr; if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; return cmdPtr; } /* |
︙ | ︙ | |||
5942 5943 5944 5945 5946 5947 5948 | int objc, /* Count of arguments. */ Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the * name of the command to invoke. */ int flags) /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { | < < < < < < < < < > | < < | > > > > > > > > > > > > > > > > | > > < < | < < < | < | | < | < < < > | < < | < < | < | < | 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 | int objc, /* Count of arguments. */ Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the * name of the command to invoke. */ int flags) /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { if (interp == NULL) { return TCL_ERROR; } if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); } int TclNRInvoke( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ const char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; if (hTblPtr != NULL) { hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid hidden command name \"%s\"", cmdName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, NULL); return TCL_ERROR; } cmdPtr = Tcl_GetHashValue(hPtr); /* Avoid the exception-handling brain damage when numLevels == 0 . */ iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* * Normal command resolution of objv[0] isn't going to find cmdPtr. * That's the whole point of **hidden** commands. So tell the * Eval core machinery not to even try (and risk finding something wrong). */ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } static int NRPostInvoke( ClientData clientData[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *)interp; iPtr->numLevels--; return result; } /* *--------------------------------------------------------------------------- * * Tcl_ExprString -- |
︙ | ︙ | |||
7292 7293 7294 7295 7296 7297 7298 | Tcl_NRCallObjProc( Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]) { | < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < | | 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 | Tcl_NRCallObjProc( Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]) { NRE_callback *rootPtr = TOP_CB(interp); TclNRAddCallback(interp, Dispatch, objProc, clientData, INT2PTR(objc), objv); return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* *---------------------------------------------------------------------- * * Tcl_NRCreateCommand -- * |
︙ | ︙ | |||
7417 7418 7419 7420 7421 7422 7423 | Tcl_NRCmdSwap( Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags) { | | > | 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 | Tcl_NRCmdSwap( Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags) { return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, (Command *) cmd); } /***************************************************************************** * Stuff for tailcalls ***************************************************************************** * * Just to show that IT CAN BE DONE! The precise semantics are not simple, |
︙ | ︙ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
83 84 85 86 87 88 89 | int objc, Tcl_Obj *const objv[]); static int BinaryDecodeHex(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); | | > > > | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | int objc, Tcl_Obj *const objv[]); static int BinaryDecodeHex(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryEncodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* * The following tables are used by the binary encoders */ |
︙ | ︙ | |||
135 136 137 138 139 140 141 | { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, { "encode", NULL, NULL, NULL, NULL, 0 }, { "decode", NULL, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { | | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, { "encode", NULL, NULL, NULL, NULL, 0 }, { "decode", NULL, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } |
︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; | < | | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; int offset = 0, count = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } TclNewObj(resultObj); data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 | TclGetStringFromObj(objv[objc-1], &count); dataend = data + count; size = (count + 1) / 2; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { | | | > | > > | | | | | | | > | | | | | | | | | < > | | < | 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 | TclGetStringFromObj(objv[objc-1], &count); dataend = data + count; size = (count + 1) / 2; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { if (data >= dataend) { value <<= 4; break; } c = *data++; if (!isxdigit((int) c)) { if (strict || !isspace(c)) { goto badChar; } i--; continue; } value <<= 4; c -= '0'; if (c > 9) { c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } value |= (c & 0xf); } if (i < 2) { cut++; } *cursor++ = UCHAR(value); value = 0; } if (cut > size) { cut = size; } |
︙ | ︙ | |||
2432 2433 2434 2435 2436 2437 2438 | *---------------------------------------------------------------------- * * BinaryEncode64 -- * * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement | | | 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 | *---------------------------------------------------------------------- * * BinaryEncode64 -- * * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object * * Side effects: * None * |
︙ | ︙ | |||
2468 2469 2470 2471 2472 2473 2474 | ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; | < | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 | ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; int offset, i, index, size, outindex = 0, count = 0; enum {OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; |
︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 | sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_MAXLEN: if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } | > > > > > > | 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 | sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_MAXLEN: if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } if (maxlen < 0) { Tcl_SetResult(interp, "line length out of range", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } |
︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 | limit = cursor + size; for (offset = 0; offset < count; offset+=3) { unsigned char d[3] = {0, 0, 0}; for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 | limit = cursor + size; for (offset = 0; offset < count; offset+=3) { unsigned char d[3] = {0, 0, 0}; for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } OUTPUT(B64Digits[d[0] >> 2]); OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { OUTPUT(B64Digits[64]); } if (offset+2 < count) { OUTPUT(B64Digits[d[2] & 0x3f]); } else { OUTPUT(B64Digits[64]); } } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } #undef OUTPUT /* *---------------------------------------------------------------------- * * BinaryEncodeUu -- * * This implements the uuencode binary encoding. Input is broken into 6 * bit chunks and a lookup table is used to turn these values into output * characters. This differs from the generic code above in that line * lengths are also encoded. * * Results: * Interp result set to an encoded byte array object * * Side effects: * None * *---------------------------------------------------------------------- */ static int BinaryEncodeUu( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; const unsigned char SingleNewline[] = { (unsigned char) '\n' }; const unsigned char *wrapchar = SingleNewline; int wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_MAXLEN: if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { return TCL_ERROR; } if (lineLength < 3 || lineLength > 85) { Tcl_SetResult(interp, "line length out of range", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); break; } } /* * Allocate the buffer. This is a little bit too long, but is "good * enough". */ resultObj = Tcl_NewObj(); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* * Encode the data. Each output line first has the length of raw data * encoded by the output line described in it by one encoded byte, then * the encoded data follows (encoding each 6 bits as one character). * Encoded lines are always terminated by a newline. */ while (offset < count) { int lineLen = count - offset; if (lineLen > rawLength) { lineLen = rawLength; } *cursor++ = UueDigits[lineLen]; for (i=0 ; i<lineLen ; i++) { n <<= 8; n |= data[offset++]; for (bits += 8; bits > 6 ; bits -= 6) { *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; } } if (bits > 0) { n <<= 8; *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } for (j=0 ; j<wrapcharlen ; ++j) { *cursor++ = wrapchar[j]; } } /* * Fix the length of the output bytearray. */ Tcl_SetByteArrayLength(resultObj, cursor-start); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* *---------------------------------------------------------------------- * * BinaryDecodeUu -- * * Decode a uuencoded string. |
︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; | | | | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; int i, index, size, count = 0, strict = 0, lineLen; unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } |
︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 | TclNewObj(resultObj); datastart = data = (unsigned char *) TclGetStringFromObj(objv[objc-1], &count); dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); while (data < dataend) { char d[4] = {0, 0, 0, 0}; for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; | > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > > > < < | < > > > | > | | > | | > | | > | > > | > > > > | > > > > > > > > > > > | > > > > > > > > > > > | > > > > > > > | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 | TclNewObj(resultObj); datastart = data = (unsigned char *) TclGetStringFromObj(objv[objc-1], &count); dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); lineLen = -1; /* * The decoding loop. First, we get the length of line (strictly, the * number of data bytes we expect to generate from the line) we're * processing this time round if it is not already known (i.e., when the * lineLen variable is set to the magic value, -1). */ while (data < dataend) { char d[4] = {0, 0, 0, 0}; if (lineLen < 0) { c = *data++; if (c < 32 || c > 96) { if (strict || !isspace(c)) { goto badUu; } i--; continue; } lineLen = (c - 32) & 0x3f; } /* * Now we read a four-character grouping. */ for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; if (c < 32 || c > 96) { if (strict) { if (!isspace(c)) { goto badUu; } else if (c == '\n') { goto shortUu; } } i--; continue; } } } /* * Translate that grouping into (up to) three binary bytes output. */ if (lineLen > 0) { *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) | (((d[1] - 0x20) & 0x3f) >> 4); if (--lineLen > 0) { *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) | (((d[2] - 0x20) & 0x3f) >> 2); if (--lineLen > 0) { *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) | (((d[3] - 0x20) & 0x3f)); lineLen--; } } } /* * If we've reached the end of the line, skip until we process a * newline. */ if (lineLen == 0 && data < dataend) { lineLen = -1; do { c = *data++; if (c == '\n') { break; } else if (c >= 32 && c <= 96) { data--; break; } else if (strict || !isspace(c)) { goto badUu; } } while (data < dataend); } } /* * Sanity check, clean up and finish. */ if (lineLen > 0 && strict) { goto shortUu; } Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; shortUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
835 836 837 838 839 840 841 | 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; | | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 | 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; int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* * There must be at least one argument after the command. */ |
︙ | ︙ | |||
864 865 866 867 868 869 870 | } /* * Remaining words (key path and value to set) can be handled normally. */ tokenPtr = TokenAfter(varTokenPtr); | | < | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 | } /* * Remaining words (key path and value to set) can be handled normally. */ tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i< parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } /* * Now emit the instruction to do the dict manipulation. */ TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } int TclCompileDictIncrCmd( |
︙ | ︙ | |||
946 947 948 949 950 951 952 | return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Emit the key and the code to actually do the increment. */ | | | < | | | < | | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 | return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Emit the key and the code to actually do the increment. */ CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } int TclCompileDictGetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ 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; int i; DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command (the single-arg * case is legal, but too special and magic for us to deal with here). */ /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); /* * Only compile this because we need INST_DICT_GET anyway. */ for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ 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; int i; DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command (the single-arg * case is legal, but too special and magic for us to deal with here). */ /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); /* * Now we do the code generation. */ for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } int TclCompileDictUnsetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ |
︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 | } /* * Get the dictionary and start the iteration. No catching of errors at * this point. */ | | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 | } /* * Get the dictionary and start the iteration. No catching of errors at * this point. */ CompileWord(envPtr, dictTokenPtr, interp, 2); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); |
︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 | * The list of variables to bind is stored in auxiliary data so that it * can't be snagged by literal sharing and forced to shimmer dangerously. */ infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { | | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 | * The list of variables to bind is stored in auxiliary data so that it * can't be snagged by literal sharing and forced to shimmer dangerously. */ infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); |
︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 | return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Issue the implementation. */ | | | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 | return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Issue the implementation. */ CompileWord(envPtr, keyTokenPtr, interp, 2); CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } int TclCompileDictWithCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ |
︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 | if (gotPath) { /* * Case: Path into dict in LVT with empty body. */ tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i<parsePtr->numWords-1 ; i++) { | | | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 | if (gotPath) { /* * Case: Path into dict in LVT with empty body. */ tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); |
︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 | if (gotPath) { /* * Case: Path into dict in non-simple var with empty body. */ tokenPtr = varTokenPtr; for (i=1 ; i<parsePtr->numWords-1 ; i++) { | | | | 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 | if (gotPath) { /* * Case: Path into dict in non-simple var with empty body. */ tokenPtr = varTokenPtr; for (i=1 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); } else { /* * Case: Direct dict in non-simple var with empty body. */ CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); PushStringLiteral(envPtr, ""); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); |
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 | keysTmp = AnonymousLocal(envPtr); /* * Issue instructions. First, the part to expand the dictionary. */ if (dictVar == -1) { | | | | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 | keysTmp = AnonymousLocal(envPtr); /* * Issue instructions. First, the part to expand the dictionary. */ if (dictVar == -1) { CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } if (dictVar == -1) { |
︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 | * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; | | | 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 | * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { return TCL_ERROR; } |
︙ | ︙ | |||
2305 2306 2307 2308 2309 2310 2311 | TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the for. */ | < < < | < | 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 | TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the for. */ if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; } SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { |
︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
︙ | ︙ | |||
81 82 83 84 85 86 87 | PushStringLiteral(envPtr, "::"); /* * Loop over the variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | > > > | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | PushStringLiteral(envPtr, "::"); /* * Loop over the variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } /* TODO: Consider what value can pass throug the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* * Pop the namespace, and set the result to empty */ |
︙ | ︙ | |||
580 581 582 583 584 585 586 587 588 589 590 591 592 593 | Tcl_DecrRefCount(objPtr); /* * Confirmed as a literal that will not frighten the horses. Compile. Note * that the result needs to be list-ified. */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); TclEmitInstInt4( INST_LIST, 1, envPtr); return TCL_OK; | > | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | Tcl_DecrRefCount(objPtr); /* * Confirmed as a literal that will not frighten the horses. Compile. Note * that the result needs to be list-ified. */ /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); TclEmitInstInt4( INST_LIST, 1, envPtr); return TCL_OK; |
︙ | ︙ | |||
1895 1896 1897 1898 1899 1900 1901 | /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will * be called at runtime. */ localTokenPtr = tokenPtr; | | | | | 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 | /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will * be called at runtime. */ localTokenPtr = tokenPtr; for (i=2; i<numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, i); PushVarNameWord(interp, localTokenPtr, envPtr, 0, &localIndex, &isScalar, i+1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } |
︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 | Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ | | < < > > | | | | | | 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 | Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } /* * Push the frame index if it is known at compile time */ objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; /* * Attempt to convert to a level reference. Note that TclObjGetFrame * only changes the obj type when a conversion was successful. */ TclObjGetFrame(interp, objPtr, &framePtr); newTypePtr = objPtr->typePtr; Tcl_DecrRefCount(objPtr); if (newTypePtr != typePtr) { if (numWords%2) { return TCL_ERROR; } /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); i = 2; } else { if (!(numWords%2)) { return TCL_ERROR; } PushStringLiteral(envPtr, "1"); otherTokenPtr = tokenPtr; i = 1; } } else { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will * be called at runtime. */ for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, i); PushVarNameWord(interp, localTokenPtr, envPtr, 0, &localIndex, &isScalar, i+1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); } |
︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 | localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); if (i+1 < numWords) { /* * A value has been given: set the variable, pop the value */ | > > > | 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 | localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } /* TODO: Consider what value can pass throug the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); if (i+1 < numWords) { /* * A value has been given: set the variable, pop the value */ |
︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 | if (parsePtr->numWords < 2 || parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } /* make room for the nsObjPtr */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; | > | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 | if (parsePtr->numWords < 2 || parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; |
︙ | ︙ | |||
2810 2811 2812 2813 2814 2815 2816 | 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 *varTokenPtr; | | < | > > > > > | | | > > | > | > > > > > > | > > > | | > > > > > > > | | < < > | > > > > > > > > > | > > > > > > > > | | < < < < > | < | > > > > > > > | | | 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 | 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 *varTokenPtr; int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* * Verify that all words - except the first non-option one - are known at * compile time so that we can handle them without needing to do a nasty * push/rotate. [Bug 3970f54c4e] */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { Tcl_Obj *leadingWord = Tcl_NewObj(); varTokenPtr = TokenAfter(varTokenPtr); if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { TclDecrRefCount(leadingWord); /* * We can tolerate non-trivial substitutions in the first variable * to be unset. If a '--' or '-nocomplain' was present, anything * goes in that one place! (All subsequent variable names must be * constants since we don't want to have to push them all first.) */ if (varCount == 0) { if (haveFlags) { continue; } /* * In fact, we're OK as long as we're the first argument *and* * we provably don't start with a '-'. If that is true, then * even if everything else is varying, we still can't be a * flag. Otherwise we'll spill to runtime to place a limit on * the trickiness. */ if (varTokenPtr->type == TCL_TOKEN_WORD && varTokenPtr[1].type == TCL_TOKEN_TEXT && varTokenPtr[1].size > 0 && varTokenPtr[1].start[0] != '-') { continue; } } return TCL_ERROR; } if (i == 1) { const char *bytes; int len; bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags = 1; } else if (len == 2 && !strncmp("--", bytes, 2)) { haveFlags = 1; } else { varCount++; } } else { varCount++; } TclDecrRefCount(leadingWord); } /* * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); if (haveFlags) { varTokenPtr = TokenAfter(varTokenPtr); } for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. */ if (isScalar) { if (localIndex < 0) { |
︙ | ︙ |
Changes to generic/tclCompExpr.c.
︙ | ︙ | |||
486 487 488 489 490 491 492 | * Keeping a stack permits the CompileExprTree() routine to be non-recursive. */ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ | < < < < < < < | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 | * Keeping a stack permits the CompileExprTree() routine to be non-recursive. */ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; /* * Declarations for local functions to this file: */ |
︙ | ︙ | |||
2257 2258 2259 2260 2261 2262 2263 | while (1) { int next; JumpList *freePtr, *newJump; if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; | | < < < < < < < < < < < < < < < < < < < < < < | 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 | while (1) { int next; JumpList *freePtr, *newJump; if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; if (nodePtr->lexeme == QUESTION) { convert = 1; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; switch (nodePtr->lexeme) { case FUNCTION: { Tcl_DString cmdName; |
︙ | ︙ | |||
2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 | */ nodePtr->left = numWords; numWords = 2; /* Command plus one argument */ break; } case QUESTION: TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: | > > > > > | | | < | > > < < > > > | > > > | 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 | */ nodePtr->left = numWords; numWords = 2; /* Command plus one argument */ break; } case QUESTION: newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; } convert = 1; break; case AND: case OR: newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { int pc1, pc2, target; switch (nodePtr->lexeme) { case START: case QUESTION: if (convert && (nodePtr == rootPtr)) { TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } break; |
︙ | ︙ | |||
2371 2372 2373 2374 2375 2376 2377 | * Each comma implies another function argument. */ numWords++; break; case COLON: CLANG_ASSERT(jumpPtr); | | < | | < | | < > > > > > > | | < | | > | | | | < < < < < < < | 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 | * Each comma implies another function argument. */ numWords++; break; case COLON: CLANG_ASSERT(jumpPtr); if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } target = jumpPtr->jump.codeOffset + 2; if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { target += 3; } freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); TclFixupForwardJump(envPtr, &jumpPtr->jump, target - jumpPtr->jump.codeOffset, 127); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); break; case AND: case OR: CLANG_ASSERT(jumpPtr); pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); convert = 0; |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
4602 4603 4604 4605 4606 4607 4608 | */ List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); | | | 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 | */ List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); for (index=toIdx+1; index<objc ; index++) { TclDecrRefCount(objv[index]); } listPtr->elemCount = toIdx+1; listPtr->canonicalFlag = 1; TclInvalidateStringRep(valuePtr); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); NEXT_INST_F(9, 0, 0); |
︙ | ︙ | |||
8644 8645 8646 8647 8648 8649 8650 | if (cfPtr->cmd == NULL) { cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); } | | < | 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 | if (cfPtr->cmd == NULL) { cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); } if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. */ ExtCmdLoc *eclPtr; ECL *locPtr = NULL; |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 | * code other than TCL_OK or TCL_ERROR; 0 means codes * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of | > | 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 | * code other than TCL_OK or TCL_ERROR; 0 means codes * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 #define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of |
︙ | ︙ | |||
2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 | MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); /* These two can be considered for the public api */ MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); | > | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 | MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); /* These two can be considered for the public api */ MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); |
︙ | ︙ |
Changes to generic/tclInterp.c.
︙ | ︙ | |||
275 276 277 278 279 280 281 282 283 284 285 286 287 288 | Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * * This routine is used to change the value of the internal variable, | > > > > > > | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; static Tcl_ObjCmdProc NRSlaveCmd; /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * * This routine is used to change the value of the internal variable, |
︙ | ︙ | |||
477 478 479 480 481 482 483 | slavePtr = &interpInfoPtr->slave; slavePtr->masterInterp = NULL; slavePtr->slaveEntryPtr = NULL; slavePtr->slaveInterp = interp; slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); | | > | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 | slavePtr = &interpInfoPtr->slave; slavePtr->masterInterp = NULL; slavePtr->slaveEntryPtr = NULL; slavePtr->slaveInterp = interp; slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
581 582 583 584 585 586 587 588 589 590 591 592 593 594 | * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp; int index; | > > > > > > > > > > | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 | * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); } static int NRInterpCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp; int index; |
︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 | } slaveInterp = Tcl_CreateInterp(); slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; | | | | 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 | } slaveInterp = Tcl_CreateInterp(); slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ |
︙ | ︙ | |||
2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 | * See user documentation for details. * *---------------------------------------------------------------------- */ static int SlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp = clientData; int index; | > > > > > > > > > > | 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 | * See user documentation for details. * *---------------------------------------------------------------------- */ static int SlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); } static int NRSlaveCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp = clientData; int index; |
︙ | ︙ | |||
3048 3049 3050 3051 3052 3053 3054 | return TCL_ERROR; } Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { | > > > > | > > > > > > > > > > > > > > > > > | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 | return TCL_ERROR; } Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { NRE_callback *rootPtr = TOP_CB(slaveInterp); Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, rootPtr, NULL, NULL); return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { result = TclObjInvokeNamespace(slaveInterp, objc, objv, (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } Tcl_TransferResult(slaveInterp, result, interp); Tcl_Release(slaveInterp); return result; } static int NRPostInvokeHidden( ClientData data[], Tcl_Interp *interp, int result) { Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; NRE_callback *rootPtr = (NRE_callback *)data[1]; if (interp != slaveInterp) { result = TclNRRunCallbacks(slaveInterp, result, rootPtr); Tcl_TransferResult(slaveInterp, result, interp); } Tcl_Release(slaveInterp); return result; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
1938 1939 1940 1941 1942 1943 1944 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); | | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int InvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ |
︙ | ︙ |
Changes to generic/tclOO.h.
︙ | ︙ | |||
35 36 37 38 39 40 41 | * * tests/oo.test * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * * tests/oo.test * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ #define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* * These are opaque types. */ typedef struct Tcl_Class_ *Tcl_Class; |
︙ | ︙ |
Changes to generic/tclOOBasic.c.
1 2 3 4 5 6 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
︙ | ︙ | |||
84 85 86 87 88 89 90 | ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); | | > | > > | | | > | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?definitionScript?"); return TCL_ERROR; } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { return TCL_OK; } /* * Delegate to [oo::define] to do the work. */ invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; /* * Must add references or errors in configuration script will cause * trouble. */ Tcl_IncrRefCount(invoke[0]); Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack * trace, so use TCL_EVAL_NOERR. */ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); } static int DecrRefsPostClassConstructor( ClientData data[], Tcl_Interp *interp, int result) { Tcl_Obj **invoke = data[0]; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); ckfree(invoke); return result; } /* * ---------------------------------------------------------------------- * * TclOO_Class_Create -- |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
1 2 3 4 5 6 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
118 119 120 121 122 123 124 | * Forwarded methods have the following extra information. */ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ | < < < < < < | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | * Forwarded methods have the following extra information. */ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ } ForwardMethod; /* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is * expected to be expanded over time). These lists are designed to be iterated |
︙ | ︙ |
Changes to generic/tclOOMethod.c.
︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 | static int CloneProcedureMethod( Tcl_Interp *interp, ClientData clientData, ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 | static int CloneProcedureMethod( Tcl_Interp *interp, ClientData clientData, ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; ProcedureMethod *pm2Ptr; Tcl_Obj *bodyObj, *argsObj; CompiledLocal *localPtr; /* * Copy the argument list. */ argsObj = Tcl_NewObj(); for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } /* * Must strip the internal representation in order to ensure that any * bound references to instance variables are removed. [Bug 3609693] */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); TclFreeIntRep(bodyObj); /* * Create the actual copy of the method record, manufacturing a new proc * record. */ pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); ckfree(pm2Ptr); return TCL_ERROR; } Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } *newClientData = pm2Ptr; return TCL_OK; } |
︙ | ︙ | |||
1334 1335 1336 1337 1338 1339 1340 | Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); | < | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 | Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); } /* * ---------------------------------------------------------------------- |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 | Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); | < | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 | Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); } /* * ---------------------------------------------------------------------- |
︙ | ︙ | |||
1405 1406 1407 1408 1409 1410 1411 | int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; | < | < | < < | < < | | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 | int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; /* * Build the real list of arguments to use. Note that we know that the * prefixObj field of the ForwardMethod structure holds a reference to a * non-empty list, so there's a whole class of failures ("not a list") we * can ignore here. */ Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int FinalizeForwardCall( ClientData data[], Tcl_Interp *interp, int result) |
︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 | ClientData clientData, ClientData *newClientData) { ForwardMethod *fmPtr = clientData; ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; | < | 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 | ClientData clientData, ClientData *newClientData) { ForwardMethod *fmPtr = clientData; ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; } /* * ---------------------------------------------------------------------- |
︙ | ︙ |
Changes to generic/tclParse.c.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclParse.h" #include <assert.h> /* * The following table provides parsing information about each possible 8-bit * character. The table is designed to be referenced with either signed or * unsigned characters, so it has 384 entries. The first 128 entries * correspond to negative character values, the next 256 correspond to * positive character values. The last 128 entries are identical to the first |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 | } /* *---------------------------------------------------------------------- * * TestdelCmd -- * | | | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | } /* *---------------------------------------------------------------------- * * TestdelCmd -- * * This procedure implements the "testdel" command. It is used * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: * Creates a command. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdelCmd( |
︙ | ︙ | |||
4228 4229 4230 4231 4232 4233 4234 | int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc > 6) { Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } | > > > > > > > > > > > > > > > > > | | > | 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 | int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc > 6) { Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } switch (argc) { case 1: Tcl_SetErrorCode(interp, "NONE", NULL); break; case 2: Tcl_SetErrorCode(interp, argv[1], NULL); break; case 3: Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); break; case 4: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); break; case 5: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); break; case 6: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], argv[5], NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TestsetobjerrorcodeCmd -- |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
3460 3461 3462 3463 3464 3465 3466 | */ static void UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; | | < | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 | */ static void UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; register int len = 3; memcpy(buffer, "end", 4); if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); } objPtr->bytes = ckalloc((unsigned) len+1); memcpy(objPtr->bytes, buffer, (unsigned) len+1); objPtr->length = len; |
︙ | ︙ |
Changes to library/auto.tcl.
︙ | ︙ | |||
508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that # replacement. return [string map [list \0 \$] $name] } if {[llength $::auto_mkindex_parser::initCommands]} { return } # Register all of the procedures for the auto_mkindex parser that will build # the "tclIndex" file. # AUTO MKINDEX: proc name arglist body # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { | > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 | set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that # replacement. return [string map [list \0 \$] $name] } # auto_mkindex_parser::indexEntry -- # # Used by commands like "proc" within the auto_mkindex parser to add a # correctly-quoted entry to the index. This is shared code so it is done # *right*, in one place. # # Arguments: # name - Name that is being added to index. proc auto_mkindex_parser::indexEntry {name} { variable index variable scriptFile # We convert all metacharacters to their backslashed form, and pre-split # the file name that we know about (which will be a proper list, and so # correctly quoted). set name [string range [list \}[fullname $name]] 2 end] set filenameParts [file split $scriptFile] append index [format \ {set auto_index(%s) [list source [file join $dir %s]]%s} \ $name $filenameParts \n] return } if {[llength $::auto_mkindex_parser::initCommands]} { return } # Register all of the procedures for the auto_mkindex parser that will build # the "tclIndex" file. # AUTO MKINDEX: proc name arglist body # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky # details here. First, we need to get the tbcload library initialized in the # current interpreter. We cannot load tbcload into the slave until we have # done so because it needs access to the tcl_patchLevel variable. Second, # because the package index file may defer loading the library until we invoke |
︙ | ︙ | |||
555 556 557 558 559 560 561 | load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { | | < < < < < < < | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { indexEntry $name } } } # AUTO MKINDEX: namespace eval name command ?arg arg...? # Adds the namespace name onto the context stack and evaluates the associated # body of commands. |
︙ | ︙ | |||
606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 | catch {$parser eval "_%@namespace import $args"} } ensemble { variable parser variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } } } } # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. | > > > > > > > < | | | < < < < | > > > > | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | catch {$parser eval "_%@namespace import $args"} } ensemble { variable parser variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] catch { set name [dict get [lrange $args 1 end] -command] if {![string match ::* $name]} { set name ::[join [lreverse $contextStack] ::]$name } regsub -all ::+ $name :: name } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } } } } # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. auto_mkindex_parser::command oo::class {op name {body ""}} { if {$op eq "create"} { indexEntry $name } } auto_mkindex_parser::command class {op name {body ""}} { if {$op eq "create"} { indexEntry $name } } return |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
18 19 20 21 22 23 24 | package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] variable patchLevel [info patchlevel] |
︙ | ︙ |
Changes to library/tm.tcl.
︙ | ︙ | |||
233 234 235 236 237 238 239 240 241 242 243 244 245 246 | try { package vcompare $pkgversion 0 } on error {} { # Ignore everything where the version part is not # acceptable to "package vcompare". continue } # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without # the namespace specifier. # NOTE. When making changes to the format of the provide | > > > > > > > > > | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | try { package vcompare $pkgversion 0 } on error {} { # Ignore everything where the version part is not # acceptable to "package vcompare". continue } if {[package ifneeded $pkgname $pkgversion] ne {}} { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. continue } # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without # the namespace specifier. # NOTE. When making changes to the format of the provide |
︙ | ︙ |
Changes to tests/binary.test.
︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 | test binary-71.9 {binary decode hex} -body { set r [binary decode hex "6"] list [string length $r] $r } -result {0 {}} test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 test binary-72.1 {binary encode base64} -body { binary encode base64 } -returnCodes error -match glob -result "wrong # args: *" test binary-72.2 {binary encode base64} -body { binary encode base64 abc } -result {YWJj} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 | test binary-71.9 {binary decode hex} -body { set r [binary decode hex "6"] list [string length $r] $r } -result {0 {}} test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 test binary-71.11 {binary decode hex: Bug b98fa55285} -body { apply {{} { set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" set decoded [binary decode hex $str] list [string length $decoded] [scan [string index $decoded end] %c] }} } -result {29 38} test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { apply {{} { set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" set decoded [binary decode hex $str] list [string length $decoded] [scan [string index $decoded end] %c] }} } -result {28 140} test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { apply {{} { set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" set decoded [binary decode hex $str] list [string length $decoded] [scan [string index $decoded end] %c] }} } -result {28 140} test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { apply {{} { set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" set decoded [binary decode hex $str] list [string length $decoded] [scan [string index $decoded end] %c] }} } -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 } -returnCodes error -match glob -result "wrong # args: *" test binary-72.2 {binary encode base64} -body { binary encode base64 abc } -result {YWJj} |
︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 | } -returnCodes error -match glob -result {invalid base64 character *} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc | | > | | | > | > | > | > | | | | | | > > > | | | > > > | | | | | | | | | | | | | | | | | | 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 | } -returnCodes error -match glob -result {invalid base64 character *} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc } -result {#86)C } test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] } -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 } -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 } -result {!`` } test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 } -result "\"``` " test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 } -result {#```` } test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 } -result {$`````` } test binary-74.10 {binary encode uuencode} -returnCodes error -body { binary encode uuencode -foo 30 abcabcabc } -result {bad option "-foo": must be -maxlen or -wrapchar} test binary-74.11 {binary encode uuencode} -returnCodes error -body { binary encode uuencode -maxlen 1 abcabcabc } -result {line length out of range} test binary-74.12 {binary encode uuencode} -body { binary encode uuencode -maxlen 3 -wrapchar | abcabcabc } -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} test binary-75.3.1 {binary decode uuencode} -body { binary decode uuencode `\n } -result {} test binary-75.4 {binary decode uuencode} -body { binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { set s "#04)\#z" binary decode uuencode $s } -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 test binary-76.1 {binary string appending growth algorithm} unix { # Create zero-length byte array first set f [open /dev/null rb] |
︙ | ︙ |
Changes to tests/coroutine.test.
︙ | ︙ | |||
605 606 607 608 609 610 611 612 613 614 615 616 617 618 | set result "" coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ {a b c d e} list $result [info command j1] [info command j2] [info command j3] } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} # cleanup unset lambda ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | set result "" coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ {a b c d e} list $result [info command j1] [info command j2] [info command j3] } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { proc foo {a b} {catch yield; return 1} } -cleanup { rename foo {} } -body { coroutine demo lsort -command foo {a b} } -result {b a} test coroutine-7.5 {return codes} { set result {} foreach code {0 1 2 3 4 5} { lappend result [catch {coroutine demo return -level 0 -code $code}] } set result } {0 1 2 3 4 5} test coroutine-7.6 {Early yield crashes} { proc foo args {} trace add execution foo enter {catch yield} coroutine demo foo rename foo {} } {} test coroutine-7.7 {Bug 2486550} -setup { interp hide {} yield } -body { coroutine demo interp invokehidden {} yield ok } -cleanup { demo interp expose {} yield } -result ok # cleanup unset lambda ::tcltest::cleanupTests return |
︙ | ︙ |
Changes to tests/dict.test.
︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 | | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are # confusing things. apply {{} {apply {n { set e {} set k {} |
︙ | ︙ | |||
1834 1835 1836 1837 1838 1839 1840 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 | | | 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} dict map {a { b }} {c {d {e {f g}}}} { ::tcl::dict::map {h { |
︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { return -level 0 "$k,$v" } } {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} test dict-24.23 {dict map results (compiled)} { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 | return [expr {$n - [linenumber]}] } } } } }} [linenumber]}} } 5 test dict-23.3 {CompileWord OBOE} { # segfault when buggy apply {{} {tcl::dict::lappend foo bar \ [format baz]}} } {bar baz} test dict-23.4 {CompileWord OBOE} { apply {n { dict set foo {*}{ } [return [incr n -[linenumber]]] val }} [linenumber] } 1 test dict-23.5 {CompileWord OBOE} { # segfault when buggy apply {{} {tcl::dict::incr foo \ [format bar]}} } {bar 1} test dict-23.6 {CompileWord OBOE} { apply {n { dict get {a b} {*}{ } [return [incr n -[linenumber]]] }} [linenumber] } 1 test dict-23.7 {CompileWord OBOE} { apply {n { dict for {a b} [return [incr n -[linenumber]]] {*}{ } {} }} [linenumber] } 2 test dict-23.8 {CompileWord OBOE} { apply {n { dict update foo {*}{ } [return [incr n -[linenumber]]] x {} }} [linenumber] } 1 test dict-23.9 {CompileWord OBOE} { apply {n { dict exists {} {*}{ } [return [incr n -[linenumber]]] }} [linenumber] } 1 test dict-23.10 {CompileWord OBOE} { apply {n { dict with foo {*}{ } [return [incr n -[linenumber]]] {} }} [linenumber] } 1 test dict-23.11 {CompileWord OBOE} { apply {n { dict with ::foo {*}{ } [return [incr n -[linenumber]]] {} }} [linenumber] } 1 test dict-23.12 {CompileWord OBOE} { apply {n { dict with {*}{ } [return [incr n -[linenumber]]] {} }} [linenumber] } 1 test dict-23.13 {CompileWord OBOE} { apply {n { dict with {*}{ } [return [incr n -[linenumber]]] {bar} }} [linenumber] } 1 test dict-23.14 {CompileWord OBOE} { apply {n { dict with foo {*}{ } [return [incr n -[linenumber]]] {bar} }} [linenumber] } 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { return -level 0 "$k,$v" } } {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} test dict-24.23 {dict map results (compiled)} { |
︙ | ︙ |
Changes to tests/error.test.
︙ | ︙ | |||
178 179 180 181 182 183 184 185 186 187 188 189 190 191 | } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} test error-4.7 {errorstack via options dict } -body { proc f x {g $x$x} proc g x {error G:$x} catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} # Errors in error command itself test error-5.1 {errors in error command} { list [catch {error} msg] $msg } {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} test error-5.2 {errors in error command} { | > > > > > > > > > > | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} test error-4.7 {errorstack via options dict } -body { proc f x {g $x$x} proc g x {error G:$x} catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} test error-4.8 {errorstack from exec traces} -body { proc foo args {} proc goo {} foo trace add execution foo enter {error bar;#} catch goo m d dict get $d -errorstack } -cleanup { rename goo {}; rename foo {} unset -nocomplain m d } -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself test error-5.1 {errors in error command} { list [catch {error} msg] $msg } {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} test error-5.2 {errors in error command} { |
︙ | ︙ |
Changes to tests/foreach.test.
︙ | ︙ | |||
249 250 251 252 253 254 255 256 257 258 259 260 261 262 | proc foo {} { foreach {} x { error "reached body" } } list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} trace add variable x write {string length $vals ;# } foreach {x y} $vals {format $y} } | > > > > > > > > > > > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | proc foo {} { foreach {} x { error "reached body" } } list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} test foreach-9.2 {line numbers} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { foreach x y {*}{ } {return [incr n -[linenumber]]} }} [linenumber] } -cleanup { rename linenumber {} } -result 1 test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} trace add variable x write {string length $vals ;# } foreach {x y} $vals {format $y} } |
︙ | ︙ |
Changes to tests/interp.test.
︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 | interp create slave } -body { slave hide coroutine slave invokehidden coroutine } -cleanup { interp delete slave } -returnCodes error -match glob -result * test interp-21.1 {interp hidden} { interp hidden {} } "" test interp-21.2 {interp hidden} { interp hidden } "" | > > > > > > > > > > > > > > | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 | interp create slave } -body { slave hide coroutine slave invokehidden coroutine } -cleanup { interp delete slave } -returnCodes error -match glob -result * test interp-20.50.1 {Bug 2486550} -setup { interp create slave } -body { slave hide coroutine catch {slave invokehidden coroutine} m o dict get $o -errorinfo } -cleanup { unset -nocomplain m 0 interp delete slave } -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within "slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} } "" test interp-21.2 {interp hidden} { interp hidden } "" |
︙ | ︙ |
Changes to tests/oo.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { |
︙ | ︙ | |||
932 933 934 935 936 937 938 939 940 941 942 943 944 945 | oo::define fooClass { forward len string length } [fooClass create foo] len a b } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass oo::class create subClass subClass create instance } -body { oo::define superClass method doit x {lappend ::result $x} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 | oo::define fooClass { forward len string length } [fooClass create foo] len a b } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { oo::object create foo unset -nocomplain ::result set ::result {} } -body { proc ::my {method} {lappend ::result global} oo::objdefine foo { method target {} {lappend ::result instance} forward bar my target method bump {} { set ns [info object namespace ::foo] rename ${ns}::my ${ns}:: rename ${ns}:: ${ns}::my } } proc harness {} { foo target foo bar foo target } trace add execution harness enterstep {apply {{cmd args} {foo bump}}} foo target foo bar foo bump foo bar harness } -cleanup { catch {rename harness {}} catch {rename ::my {}} foo destroy } -result {instance instance instance instance instance instance} test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { oo::class create fooClass fooClass create foo unset -nocomplain ::result set ::result {} } -body { proc ::my {method} {lappend ::result global} oo::define fooClass { method target {} {lappend ::result class} forward bar my target method bump {} { set ns [info object namespace [self]] rename ${ns}::my ${ns}:: rename ${ns}:: ${ns}::my } } proc harness {} { foo target foo bar foo target } trace add execution harness enterstep {apply {{cmd args} {foo bump}}} foo target foo bar foo bump foo bar harness } -cleanup { catch {rename harness {}} catch {rename ::my {}} fooClass destroy } -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass oo::class create subClass subClass create instance } -body { oo::define superClass method doit x {lappend ::result $x} |
︙ | ︙ | |||
1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 | method <cloned> {a b} {} } interp alias {} Bar {} oo::copy [Foo create foo] Bar bar } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar <cloned> a b"} test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 | method <cloned> {a b} {} } interp alias {} Bar {} oo::copy [Foo create foo] Bar bar } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar <cloned> a b"} test oo-15.10 {variable binding must not bleed through oo::copy} -setup { oo::class create FooClass set result {} } -body { set obj1 [FooClass new] oo::objdefine $obj1 { variable var method m {} { set var foo } method get {} { return $var } export eval } $obj1 m lappend result [$obj1 get] set obj2 [oo::copy $obj1] $obj2 eval { set var bar } lappend result [$obj2 get] $obj1 eval { set var grill } lappend result [$obj1 get] [$obj2 get] } -cleanup { FooClass destroy } -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} |
︙ | ︙ |
Changes to tests/ooNext2.test.
1 2 3 4 5 6 7 8 9 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { |
︙ | ︙ |
Changes to tests/rename.test.
︙ | ︙ | |||
136 137 138 139 140 141 142 143 144 145 146 147 148 149 | foo alias kill kill testdel foo cmd {set env(value) deleted; kill} list [catch {interp delete foo} msg] $msg $env(value) } {0 {} deleted} if {[info exists env(value)]} { unset env(value) } # Save the unknown procedure which is modified by the following test. catch {rename unknown unknown.old} set SAVED_UNKNOWN "proc unknown " append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]] | > > > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | foo alias kill kill testdel foo cmd {set env(value) deleted; kill} list [catch {interp delete foo} msg] $msg $env(value) } {0 {} deleted} if {[info exists env(value)]} { unset env(value) } test rename-4.8 {Bug a16752c252} testdel { set x broken testdel {} foo {set x ok} proc foo args {} rename foo {} return -level 0 $x[unset x] } ok # Save the unknown procedure which is modified by the following test. catch {rename unknown unknown.old} set SAVED_UNKNOWN "proc unknown " append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]] |
︙ | ︙ |
Changes to tests/safe.test.
︙ | ︙ | |||
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (static package)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] } -constraints TcltestPackage -body { interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i | > > > > > > > > > > > > > > > > > > > > > > > > > | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { catch {interp eval $i {load {} Safepkg1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within "interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (static package)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] } -constraints TcltestPackage -body { interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within "interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i |
︙ | ︙ | |||
497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 | test safe-11.7 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] } -body { $i eval glob ../* } -returnCodes error -cleanup { safe::interpDelete $i | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 | test safe-11.7 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { catch {interp eval $i encoding convertfrom} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data" while executing "encoding convertfrom" invoked from within "::interp invokehidden interp1 encoding convertfrom" invoked from within "encoding convertfrom" invoked from within "interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { catch {interp eval $i encoding convertto} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data" while executing "encoding convertto" invoked from within "::interp invokehidden interp1 encoding convertto" invoked from within "encoding convertto" invoked from within "interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] } -body { $i eval glob ../* } -returnCodes error -cleanup { safe::interpDelete $i |
︙ | ︙ | |||
711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | lappend result [interp invokehidden $i file split a/b/c] lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp invokehidden $i file isdirectory .}] interp expose $i file lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar set i [safe::interpCreate] } -body { | > > > > > > > > > > > > > > > > > > > > > | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 | lappend result [interp invokehidden $i file split a/b/c] lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp invokehidden $i file isdirectory .}] interp expose $i file lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} test safe-15.1.1 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { set result [expr {"file" in [interp hidden $i]}] lappend result [interp eval $i {tcl::file::split a/b/c}] lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] lappend result [interp invokehidden $i file split a/b/c] lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp invokehidden $i file isdirectory .}] interp expose $i file lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] } -cleanup { unset -nocomplain msg o interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file while executing "file isdirectory ." invoked from within "interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar set i [safe::interpCreate] } -body { |
︙ | ︙ |
Changes to tests/trace.test.
︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 | list $::traceCalls | {*}$res } -cleanup { unset ::traceLog ::traceCalls res rename dotrace {} rename foo {} } -result {3 | 0 1 1} # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} catch {rename untraced {}} | > > > > > > > | 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 | list $::traceCalls | {*}$res } -cleanup { unset ::traceLog ::traceCalls res rename dotrace {} rename foo {} } -result {3 | 0 1 1} test trace-40.1 {execution trace errors become command errors} { proc foo args {} trace add execution foo enter {rename foo {}; error bar;#} catch foo m return -level 0 $m[unset m] } bar # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} catch {rename untraced {}} |
︙ | ︙ |
Changes to tests/upvar.test.
︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 | catch {unset a} catch {unset x} set a(b) 1234 foo } {1234} catch {unset a} # # Tests for 'namespace upvar'. As the implementation is essentially the same as # for 'upvar', we only test that the variables are linked correctly, i.e., we # assume that the behaviour of variables once the link is established has # already been tested above. # | > > > > > > > > > > > | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | catch {unset a} catch {unset x} set a(b) 1234 foo } {1234} catch {unset a} test upvar-10.1 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { upvar 1 {*}{ } [return [incr n -[linenumber]]] x }} [linenumber] } -cleanup { rename linenumber {} } -result 1 # # Tests for 'namespace upvar'. As the implementation is essentially the same as # for 'upvar', we only test that the variables are linked correctly, i.e., we # assume that the behaviour of variables once the link is established has # already been tested above. # |
︙ | ︙ | |||
532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 | test upvar-NS-2.2 {TIP 323} -setup { namespace eval test_ns_1 {} } -body { namespace upvar test_ns_1 } -cleanup { namespace delete test_ns_1 } -result {} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 | test upvar-NS-2.2 {TIP 323} -setup { namespace eval test_ns_1 {} } -body { namespace upvar test_ns_1 } -cleanup { namespace delete test_ns_1 } -result {} test upvar-NS-3.1 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { namespace upvar {*}{ } [return [incr n -[linenumber]]] x y }} [linenumber] } -cleanup { rename linenumber {} } -result 1 test upvar-NS-3.2 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { namespace upvar :: {*}{ } [return [incr n -[linenumber]]] x }} [linenumber] } -cleanup { rename linenumber {} } -result 1 test upvar-NS-3.3 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { variable x {*}{ } [return [incr n -[linenumber]]] }} [linenumber] } -cleanup { rename linenumber {} } -result 1 # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/var.test.
︙ | ︙ | |||
744 745 746 747 748 749 750 751 752 753 754 755 756 757 | # Note that the variable name has to be # unused previously for the segfault to # be triggered. # namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" catch {error foo bar baz} trace remove variable ::errorCode write " ;#" set ::errorInfo } bar | > > > | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 | # Note that the variable name has to be # unused previously for the segfault to # be triggered. # namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { apply {{} {unset foo [return ok]}} } ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" catch {error foo bar baz} trace remove variable ::errorCode write " ;#" set ::errorInfo } bar |
︙ | ︙ | |||
858 859 860 861 862 863 864 865 866 867 868 869 870 871 | unset -nocomplain x } -body { apply {{} { eval {array set ::x {}} }} array size x } -result 0 catch {namespace delete ns} catch {unset arr} catch {unset v} catch {rename p ""} catch {namespace delete test_ns_var} | > > > > > > > > > > > > > | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 | unset -nocomplain x } -body { apply {{} { eval {array set ::x {}} }} array size x } -result 0 test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { set foo bar unset foo {*}{ } [return [incr n -[linenumber]]] }} [linenumber] } -cleanup { rename linenumber {} } -result 1 catch {namespace delete ns} catch {unset arr} catch {unset v} catch {rename p ""} catch {namespace delete test_ns_var} |
︙ | ︙ |
Changes to tests/zlib.test.
︙ | ︙ | |||
229 230 231 232 233 234 235 | catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" | | | | > | > > | | | | | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] catch {zlib decompress $compressed} err opt list [string length [zlib compress $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] [zlib adler32 $spdyDict] } -cleanup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders set result [fconfigure $outSide -checksum] chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] lappend result [string length $spdyHeaders] [string length [$strm get]] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] catch { zlib inflate $compressed throw UNREACHABLE "should be unreachable" } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] } -cleanup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] list [string length $spdyHeaders] [string length [$strm get]] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358} test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide fconfigure $outSide -blocking 0 -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ [fconfigure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary fconfigure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ [fconfigure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide fconfigure $outSide -blocking 0 -buffering none -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358} test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -buffering none -translation binary fconfigure $inSide -translation binary |
︙ | ︙ |
Changes to unix/Makefile.in.
︙ | ︙ | |||
846 847 848 849 850 851 852 | @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; @echo "Installing package tcltest 2.3.6 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; |
︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
︙ | ︙ | |||
456 457 458 459 460 461 462 | return TCL_ERROR; } } switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { | | | | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 | return TCL_ERROR; } } switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { char linkBuf[MAXPATHLEN+1]; int length; length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; } linkBuf[length] = '\0'; if (symlink(linkBuf, dst) < 0) { /* INTL: Native. */ return TCL_ERROR; |
︙ | ︙ |
Changes to unix/tclUnixSock.c.
︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 | status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); if (status == -1) { if (howfar < BIND) { howfar = BIND; my_errno = errno; } close(sock); continue; } if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); /* | > | 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 | status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); if (status == -1) { if (howfar < BIND) { howfar = BIND; my_errno = errno; } close(sock); sock = -1; continue; } if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); /* |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 | status = listen(sock, SOMAXCONN); if (status < 0) { if (howfar < LISTEN) { howfar = LISTEN; my_errno = errno; } close(sock); continue; } if (statePtr == NULL) { /* * Allocate a new TcpState for this socket. */ | > | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 | status = listen(sock, SOMAXCONN); if (status < 0) { if (howfar < LISTEN) { howfar = LISTEN; my_errno = errno; } close(sock); sock = -1; continue; } if (statePtr == NULL) { /* * Allocate a new TcpState for this socket. */ |
︙ | ︙ |
Changes to unix/tclooConfig.sh.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" | | | 12 13 14 15 16 17 18 19 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" TCLOO_VERSION=1.0.1 |
Changes to win/Makefile.in.
︙ | ︙ | |||
580 581 582 583 584 585 586 | do \ if [ -f $$i ]; then \ echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ | | | | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | do \ if [ -f $$i ]; then \ echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ echo Installing $(DDE_DLL_FILE); \ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(REG_DLL_FILE) ]; then \ echo Installing $(REG_DLL_FILE); \ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi install-libraries: libraries install-tzdata install-msgs @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ $(SCRIPT_INSTALL_DIR); \ do \ |
︙ | ︙ | |||
646 647 648 649 650 651 652 | @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; | | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 | @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; @echo "Installing package tcltest 2.3.6 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ |
︙ | ︙ |
Changes to win/makefile.bc.
︙ | ︙ | |||
405 406 407 408 409 410 411 | $(cc32) $(CONS_CFLAGS) -o$(TMPDIR)\cat.obj $? $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \ $(TMPDIR)\cat.obj, $@, -x, $(LNLIBS),, install-binaries: $(TCLSH) $(MKDIR) "$(BIN_INSTALL_DIR)" $(MKDIR) "$(LIB_INSTALL_DIR)" | | | | | | | | | | | | | | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | $(cc32) $(CONS_CFLAGS) -o$(TMPDIR)\cat.obj $? $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \ $(TMPDIR)\cat.obj, $@, -x, $(LNLIBS),, install-binaries: $(TCLSH) $(MKDIR) "$(BIN_INSTALL_DIR)" $(MKDIR) "$(LIB_INSTALL_DIR)" @echo Installing $(TCLDLLNAME) @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)" @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)" @echo Installing "$(TCLSH)" @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)" @echo Installing $(TCLSTUBLIBNAME) @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)" @echo Installing $(WINDIR)\tclooConfig.sh @copy "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)" install-libraries: -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" @echo Installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" @echo Installing http2.8 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" @echo Installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" @echo Installing msgcat1.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" @echo Installing tcltest2.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" @echo Installing $(TCLDDEDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3" @echo Installing $(TCLREGDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.3" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2" @echo Installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" @echo Installing library files -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)" |
︙ | ︙ |
Changes to win/tclooConfig.sh.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" | | | 12 13 14 15 16 17 18 19 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" TCLOO_VERSION=1.0.1 |